{-# LANGUAGE GADTs #-} module UHC.Light.Compiler.EHC.BuildFunction.Run ( module UHC.Light.Compiler.EHC.BuildFunction , bcall , bderef ) where import UHC.Light.Compiler.EHC.BuildFunction import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileRun import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.FileSuffMp import UHC.Light.Compiler.EHC.ASTHandler import UHC.Light.Compiler.EHC.ASTHandler.Instances import UHC.Util.Lens import Data.Typeable import qualified Data.Map as Map import Control.Monad.State import Control.Monad.Error import System.Directory import UHC.Light.Compiler.Base.PackageDatabase {-# LINE 53 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Execute a build function, possibly caching/memoizing a result bcall :: forall res m . (Typeable res) => EHCCompileRunner m => BFun' res -> EHCompilePhaseT m res bcall bfun = do bcache <- getl $ st ^* bstateCache mbCachedRes <- lkup bfun bcache case mbCachedRes of Just res -> return res _ -> do -- prepare start -- actual execution res <- case bfun of EcuOfName modNm -> do bcall $ EcuOfNameAndPath Nothing (modNm, Nothing) EHCOptsOf modNm -> do fmap (panicJust "EHCOptsOf") $ bderef (BRef_EHCOpts modNm) EcuOfNameAndPath mbPrev (modNm,mbFp) -> do opts <- bcall $ EHCOptsOf modNm let isTopModule = isJust mbFp searchPath = ehcOptImportFileLocPath opts adaptFileSuffMp = if isTopModule then (fileSuffMpHsNoSuff ++) else id fileSuffMpHs <- fmap (map tup123to12 . adaptFileSuffMp) $ getl $ crStateInfo ^* crsiFileSuffMp let searchPath' = prevSearchInfoAdaptedSearchPath mbPrev searchPath fpsFound <- cpFindFilesForFPathInLocations (fileLocSearch opts) tup123to1 False fileSuffMpHs searchPath' (Just modNm) mbFp when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ do putStrLn $ show modNm ++ ": " ++ show (fmap fpathToStr mbFp) ++ ": " ++ show (map fpathToStr fpsFound) putStrLn $ "searchPath: " ++ show searchPath' when isTopModule (cpUpdCU modNm (ecuSetIsTopMod True)) bmemo $ BRef_ECU modNm fmap (panicJust "EcuOfNameAndPath") $ cpMbCU modNm FPathSearchForFile suff fn -> do let fp = mkTopLevelFPath suff fn modNm = mkHNm $ fpathBase fp breturn (modNm, fp) ASTFromFile mf asttype skey@(astfcont,_) tkey -> do ecu <- bcall $ EcuOfNameAndPath Nothing mf let modNm = ecuModNm ecu fp = ecuFilePath ecu ref = BRef_AST modNm asttype skey tkey opts <- bcall $ EHCOptsOf modNm mbtm <- bcall $ ModfTimeOfFile modNm asttype skey tkey (_ :: Maybe res, mbset) <- bderef' ref case (mbtm, mbset, asthandlerLookup asttype) of (Just _, Just set, Just (astHdlr :: ASTHandler' res)) | isJust mbi && isJust mbl -> case astfcont of ASTFileContent_Binary -> do cpMsg' modNm VerboseALot "Decoding" Nothing fpC mbx@(~(Just x)) <- liftIO $ _asthdlrGetSerializeFileIO astHdlr opts fpC if isJust mbx then do let errs = _asthdlrPostInputCheck astHdlr opts ecu modNm fpC x if null errs then do set x bmemo ref return x else do cpSetLimitErrsWhen 1 ("Decode AST check " ++ _asthdlrName astHdlr) errs dflt' else err "decoder" _ -> err "ast content handler" where mbi@(~(Just info)) = astsuffixLookup skey $ _asthdlrSuffixRel astHdlr mbl@(~(Just lens)) = Map.lookup tkey $ _astsuffinfoASTLensMp info fpC = asthdlrMkInputFPath astHdlr opts ecu skey modNm fp err = err' (_asthdlrName astHdlr) _ -> err' "" "ast handler/setter" where dflt' = return undefined err' k m = do cpSetLimitErrsWhen 1 ("Decode " ++ k) [strMsg $ "No " ++ m ++ " for " ++ k ++ " (" ++ show skey ++ "/" ++ show tkey ++ ")"] dflt' ModfTimeOfFile modNm asttype skey tkey -> case (asthandlerLookup' asttype $ \hdlr -> do suffinfo <- astsuffixLookup skey $ _asthdlrSuffixRel hdlr lens <- Map.lookup tkey $ _astsuffinfoModfTimeMp suffinfo return (_astsuffinfoSuff suffinfo, lens) ) of Just (suff, lens) -> do cr <- get let (ecu,_,opts,fp) = crBaseInfo modNm cr tm opts ecu ((lens ^=) . Just) (fpathSetSuff suff fp) _ -> return Nothing where tm opts ecu store fp = do let n = fpathToStr fp nExists <- liftIO $ doesFileExist n when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("meta info of: " ++ show (ecuModNm ecu) ++ ", file: " ++ n ++ ", exists: " ++ show nExists) if nExists then do t <- liftIO $ fpathGetModificationTime fp when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("time stamp of: " ++ show (ecuModNm ecu) ++ ", time: " ++ show t) cpUpdCU modNm $ store t return $ Just t else return Nothing _ -> panic $ "BuildFunction.Run.bcall: not implemented: " ++ show bfun -- finalize end return res where -- lens access st = crStateInfo ^* crsiBState cstk = st ^* bstateCallStack -- call init/finalization start = cstk =$: (BFun bfun :) end = cstk =$: tail -- memoize bmemo :: Typeable f => f res -> EHCompilePhaseT m () bmemo res = do (BFun bfun : _) <- getl $ st ^* bstateCallStack case cast bfun of Just bfun -> st ^* bstateCache =$: bcacheInsert bfun res _ -> panic $ "BuildFunction.Run.bcall.bmemo: " ++ show bfun -- memoize & return breturn :: res -> EHCompilePhaseT m res breturn res = do bmemo (Identity res) return res -- lookup in cache lkup :: BFun' res -> BCache -> EHCompilePhaseT m (Maybe res) lkup bfun bcache = case bcacheLookup bfun bcache of Just (res :: Identity res) -> return $ Just $ runIdentity res _ -> case bcacheLookup bfun bcache of Just (ref :: BRef res) -> bderef ref _ -> return Nothing {-# LINE 215 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Dereference an indirection into compilation state, possibly with a result, and a setter bderef' :: forall res m . (Typeable res, EHCCompileRunner m) => BRef res -> EHCompilePhaseT m (Maybe res, Maybe (res -> EHCompilePhaseT m ())) bderef' bref = do cr <- get case bref of BRef_ECU modNm -> return (crMbCU modNm cr, Just $ \ecu -> cpUpdCU modNm (const ecu)) BRef_EHCOpts modNm -> return (Just choose, Nothing) where opts = cr ^. crStateInfo ^. crsiOpts choose = maybe opts id $ crMbCU modNm cr >>= ecuMbOpts BRef_AST modNm asttype skey tkey -> case asthandlerLookup asttype of Just (hdlr :: ASTHandler' res) -> case astsuffixLookup skey $ _asthdlrSuffixRel hdlr of Just suffinfo -> case Map.lookup tkey $ _astsuffinfoASTLensMp suffinfo of Just l -> do ecu <- bcall $ EcuOfName modNm return (ecu ^. l, Just $ \ast -> cpUpdCU modNm $ l ^= Just ast) _ -> dflt _ -> dflt _ -> dflt where dflt = return (Nothing, Nothing) -- | Dereference an indirection into compilation state bderef :: forall res m . (Typeable res, EHCCompileRunner m) => BRef res -> EHCompilePhaseT m (Maybe res) bderef bref = fmap fst $ bderef' bref