{-# LANGUAGE GADTs, TemplateHaskell, KindSignatures #-} module UHC.Light.Compiler.EHC.CompileRun.Base ( module UHC.Light.Compiler.CodeGen.CEnv , BuildGlobal (..) , BFun' (..) , BFun (..) , BFunCacheEntry (..) , BCache (..), emptyBCache , bcacheResolveModNm , BRef (..) , ASTResult (..) , mkASTResult' , mkASTResult , BState, emptyBState , EHCompileRunCoreRunStateInfo (..), emptyEHCompileRunCoreRunStateInfo , EHCompileRunStateInfo (..) , emptyEHCompileRunStateInfo , EHCCompileRunner , EHCompileRun, EHCompilePhaseT, EHCompilePhase , TmOfRes (..), emptyTmOfRes , bcacheCache, bcacheDpdRel, bcacheModNmForward , bstateCache, bstateCallStack , crcrsiReqdModules, crcrsiNm2RefMp , crsiOpts, crsiASTPipe, crsiNextUID, crsiHereUID, crsiHSInh, crsiEHInh, crsiBState, crsiFileSuffMp , crsiCEnv , crsiCoreRunState , astresAST, astresRef, astresPipe , tmofresChoice, tmofresIsOverr, tmofresHasMain , crBaseInfo, crMbBaseInfo, crBaseInfo' , cpStepUID, cpSetUID , cpTrPP, cpTr , cpMsg, cpMsg' , cpSystem', cpSystem , cpSystemRaw , bUpdAlreadyFlowIntoCRSIWith, bUpdAlreadyFlowIntoCRSI , bLookupECUInCR, bLookupECU', bLookupECU, bUpdECU , TmOfResMb, TmOfResM, updTmChoice, updTmChoiceM , TmOfDelayedRes (..), emptyTmOfDelayedRes , astresTimeStamp , tmofdresModNm, tmofdresHasMain, tmofdresImpMp , tmofresDelayed, tmofresTm , crsiExpNmOffMpDbg, crsiExpNmOffMp , EHCIOInfo (..) , EHCTime , EHCTimeDiff, getEHCTime, ehcTimeDiff, ehcTimeDiffFmt , cpRegisterFilesToRm , cpRmFilesToRm , crPartitionIntoPkgAndOthers ) where import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IMap import Data.Maybe import qualified UHC.Util.RelMap as Rel import UHC.Util.Hashable import Control.Exception as CE import UHC.Util.Lens import Data.Functor.Identity import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.Base.Trace import UHC.Light.Compiler.EHC.FileSuffMp import UHC.Light.Compiler.Base.Optimize import Control.Monad.State hiding (get) import qualified Control.Monad.State as MS import Control.Applicative import UHC.Util.Error import Control.Monad.Fix import System.IO import System.Exit import System.Environment import System.Process import UHC.Light.Compiler.EHC.CompileUnit import qualified UHC.Light.Compiler.CoreRun as CoreRun import UHC.Light.Compiler.CodeGen.ValAccess as VA import UHC.Light.Compiler.CodeGen.CEnv import UHC.Light.Compiler.EHC.CompileGroup import qualified UHC.Light.Compiler.HS.ModImpExp as HSSemMod import UHC.Light.Compiler.CodeGen.ModuleImportExportImpl import UHC.Light.Compiler.Module.ImportExport import UHC.Util.Time import System.CPUTime import System.Locale import Data.IORef import System.IO.Unsafe import System.Directory import UHC.Util.FPath import UHC.Util.Time import System.CPUTime import System.Locale import Data.IORef import System.IO.Unsafe import UHC.Light.Compiler.Base.PackageDatabase import qualified UHC.Light.Compiler.Base.Pragma as Pragma {-# LINE 101 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Global parameterisation for build calls data BuildGlobal = BuildGlobal { _bglobPipe :: ASTPipe -- ^ the global pipe for the current compilation, required when recursing into imported modules } deriving (Eq, Ord, Typeable, Generic) instance Hashable BuildGlobal instance Show BuildGlobal where show (BuildGlobal p) = "Glob(" ++ show p ++ ")" instance PP BuildGlobal where pp (BuildGlobal p) = "Glob" >#< p {-# LINE 123 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Representation of build functions (embedded comment screws up haddock, hence see source code directly). -- Regretfully deriving Generic (and thus Hashable) does not work for GADTs, so must be done manually, below. -- Ord cannot be derived either. -- First order type, no fields with recursive type are allowed to allow for more easily implementable comparison etc. data BFun' m res where --- | Obtain global state CRSI :: BFun' m (EHCompileRunStateInfo m) --- | Obtain global state specific for compile order CRSIWithCompileOrderPl :: !BuildGlobal -> ![[HsName]] --- ^ compile order -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m (EHCompileRunStateInfo m) --- | Obtain global state specific for imports CRSIWithImpsPl :: !BuildGlobal -> !PrevFileSearchKey -> !(Set.Set HsName) --- ^ imports -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m (EHCompileRunStateInfo m) {- --- | Obtain global state specific for a module, which depends on the (imported) module names CRSIOfName :: !PrevFileSearchKey --- ^ module name etc -> !ASTType --- ^ content type -> BFun' m EHCompileRunStateInfo -} CRSIOfNameP :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name etc -> !ASTPipe --- ^ pipeline leading to content -> BFun' m (EHCompileRunStateInfo m) CRSIOfNamePl :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name etc -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m (EHCompileRunStateInfo m) --- | Obtain FPath and module name of a file name FPathSearchForFile :: !String --- ^ suffix, if absent in name -> !FilePath --- ^ file name -> BFun' m (HsName, FPath) --- | Obtain FPath of module taking into account ast type, overriding, suffix etc FPathForAST :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m (FPath, ASTFileSuffOverride, EHCompileUnit) --- | Extract imported modules from a module ImportsOfNamePl :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name etc -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m (HsName, Set.Set HsName) --- | Extract recursively all import relationships starting with imports ImportsRecursiveWithImpsP :: !BuildGlobal -> !(Maybe PrevSearchInfo) -> !(Set.Set HsName) --- ^ imports -> !ASTPipe --- ^ pipeline leading to content -> BFun' m ( Map.Map HsName (Set.Set HsName) -- recursive result ) --- | Extract recursively all import relationships starting with module ImportsRecursiveOfNameP :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name etc -> !ASTPipe --- ^ pipeline leading to content -> BFun' m ( HsName -- the actual module name , Set.Set HsName -- imports , Map.Map HsName (Set.Set HsName) -- recursive result ) --- | Extract compileunit from a module, as is, no checks on consistency EcuOf :: !HsName --- ^ module name -> BFun' m EHCompileUnit {- --- | Extract compileunit from a module, including file path etc walking, suffix detection EcuOfName :: !HsName --- ^ module name -> BFun' m EHCompileUnit -} EcuOfPrevNameAndPath :: !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m EHCompileUnit {- EcuOfNameAndPath :: !FileSearchKey --- ^ module name and possibly known path -> BFun' m EHCompileUnit -} --- | Extract global options, possibly overridden for a module EHCOptsOf :: !PrevFileSearchKey --- ^ module name -> BFun' m EHCOpts --- | Actual module name, as it occurs in module itself ActualModNm :: !PrevFileSearchKey --- ^ module name -> BFun' m HsName --- | The build plan for a pipe BuildPlanPMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m (Maybe ASTBuildPlan) --- | The build plan choice for a pipe ASTBuildPlanChoicePMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m (Maybe (TmOfRes m)) ASTRefFromFileEither :: Typeable ast => !PrevFileSearchKey --- ^ module name and possibly known path -> !Bool --- ^ errors are returned instead of reported directly -> !(AlwaysEq ASTFileTimeHandleHow) --- ^ how to deal with timestamp -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m (Either (String,[Err]) (BRef m ast)) {- ASTRefFromFileMb :: Typeable ast => !PrevFileSearchKey --- ^ module name and possibly known path -> !(AlwaysEq ASTFileTimeHandleHow) --- ^ how to deal with timestamp -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m (Maybe (BRef m ast)) -} --- | Get a particular AST from file for a module ASTFromFile :: !PrevFileSearchKey --- ^ module name and possibly known path -> !(AlwaysEq ASTFileTimeHandleHow) --- ^ how to deal with timestamp -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m res --- | Get a particular AST for a module ASTP :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m res ASTPMb :: Typeable ast => !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m (Maybe (ASTResult m ast)) ASTPlMb :: Typeable ast => !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ build plan leading to content -> BFun' m (Maybe (ASTResult m ast)) --- | Get the modification ClockTime of a file for a module ModfTimeOfFile :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m (Maybe ( ClockTime , FPath ) ) --- | Valid AST from file? ASTFileIsValid :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTType --- ^ content type -> !ASTSuffixKey --- ^ suffix and content variation -> !ASTFileTiming --- ^ timing (i.e. previous or current) -> BFun' m Bool --- | Compare timestamps, if possible, yield True if first is new than second ASTFileIsNewerThan :: !(PrevFileSearchKey --- ^ 1st module name and possibly known path ,ASTType --- ^ 1st content type ,ASTSuffixKey --- ^ 1st suffix and content variation ,ASTFileTiming --- ^ 1st timing (i.e. previous or current) ) -> !(PrevFileSearchKey --- ^ 2nd module name and possibly known path ,ASTType --- ^ 2nd content type ,ASTSuffixKey --- ^ 2nd suffix and content variation ,ASTFileTiming --- ^ 2nd timing (i.e. previous or current) ) -> BFun' m (Maybe Bool) --- | Get writeability of the dir a module resides in DirOfModIsWriteable :: !PrevFileSearchKey --- ^ module name and possibly known path -> !LinkingStyle -> BFun' m Bool --- | Can compile a src module CanCompile :: !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m Bool {- --- | Src module needs (re)compilation NeedsCompile :: !HsName --- ^ module name and possibly known path -> BFun' m Bool -} --- | Module is top module, i.e. specified at commandline with possibly different name than module name in file IsTopMod :: !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m Bool --- | Module has a 'main' HasMain :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m Bool --- | The result of folding over a module for import/module analysis FoldHsMod :: !PrevFileSearchKey --- ^ module name and possibly known path -> !(Maybe [PkgModulePartition]) --- ^ optionally do CPP with module partitioning into pkgs -> BFun' m ( AST_HS_Sem_Mod -- all semantics , Bool -- has main? , Set.Set Pragma.Pragma -- pragmas , Maybe EHCOpts -- possibly adapted options ) {- --- | The actual module name and imported modules, abstracted over the AST type ModnameAndImports :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTType --- ^ ast type -> BFun' m ( HsName -- module name , Set.Set HsName -- imported module names , Maybe PrevSearchInfo -- search info for modules to be imported from this one , Bool -- has main ) --- | The actual module name and imported modules, abstracted over the AST type ModnameAndImportsP :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m ( HsName -- module name , Set.Set HsName -- imported module names , Maybe PrevSearchInfo -- search info for modules to be imported from this one , Bool -- has main ) -} --- | The actual module name and imported modules, abstracted over the AST type ModnameAndImportsPlMb :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( HsName -- module name , Set.Set HsName -- imported module names , Maybe PrevSearchInfo -- search info for modules to be imported from this one , Bool -- has main ) ) {- --- | The actual module name and imported modules, abstracted over the AST type ModnameAndImportsPlMb :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( HsName -- module name , Set.Set HsName -- imported module names , Maybe PrevSearchInfo -- search info for modules to be imported from this one ) ) -} --- | See 'ModnameAndImports', for HS HsModnameAndImports :: !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m ( HsName -- module name , Set.Set HsName -- imported module names , Maybe PrevSearchInfo -- search info for modules to be imported from this one , Bool -- is main module? ) --- | HIInfo FoldHIInfo :: !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m ( AST_HI -- all semantics , Set.Set HsName -- declared imported module names , Set.Set HsName -- used imported module names , Bool -- is main module? ) --- | Imported names info for codegen ImportNameInfo :: !PrevFileSearchKey --- ^ module name and possibly known path -> OptimizationScope --- ^ scope for which this holds -> BFun' m [HsName] --- | Import/Export info for module codegen ImportExportImpl :: !PrevFileSearchKey --- ^ module name and possibly known path -> OptimizationScope -> BFun' m ModuleImportExportImpl --- | HS semantics FoldHsPMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_HS_Sem_Check -- all semantics -- , Set.Set HsName -- declared imported module names , Bool -- is main module? ) ) --- | HS semantics FoldHsPlMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_HS_Sem_Check -- all semantics -- , Set.Set HsName -- declared imported module names , Bool -- is main module? ) ) --- | EH semantics FoldEHPMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTPipe --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_EH_Sem_Check -- all semantics ) ) --- | EH semantics FoldEHPlMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_EH_Sem_Check -- all semantics ) ) --- | Core as src semantics FoldCoreModPlMb :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_Core_Sem_Check -- all semantics , HsName -- real mod name , Set.Set HsName -- declared imported module names , Mod -- module import/export etc info , Bool -- is main module? , Maybe PrevSearchInfo ) ) --- | Core -> CoreRun semantics FoldCore2CoreRunPlMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_Core_Sem_ToCoreRun -- all semantics ) ) --- | CoreRun as src semantics FoldCoreRunModPlMb :: !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_CoreRun_Sem_Mod -- all semantics , HsName -- real mod name , Set.Set HsName -- declared imported module names , Mod -- module import/export etc info , Bool -- is main module? , Maybe PrevSearchInfo ) ) --- | CoreRun as src semantics FoldCoreRunCheckPlMb :: !BuildGlobal -> !PrevFileSearchKey --- ^ module name and possibly known path -> !ASTBuildPlan --- ^ pipeline leading to content -> BFun' m ( Maybe ( AST_CoreRun_Sem_Check -- all semantics , AST_CoreRun -- updated CoreRun ) ) --- | Get the FPath of the possibly with CPP preprocessed file FPathPreprocessedWithCPP :: [PkgModulePartition] --- ^ partitioning of modules into packages -> !PrevFileSearchKey --- ^ module name and possibly known path -> BFun' m FPath --- | Exposed packages ExposedPackages :: BFun' m [PkgModulePartition] -- | Comparison which ignores GADT type info bfunCompare :: BFun' m res1 -> BFun' m res2 -> Ordering bfunCompare f1 f2 = case (f1,f2) of (CRSI , CRSI ) -> EQ (CRSIWithCompileOrderPl a1 b1 c1 , CRSIWithCompileOrderPl a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (CRSIWithImpsPl a1 b1 c1 d1 , CRSIWithImpsPl a2 b2 c2 d2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2] (CRSIOfNameP a1 b1 c1 , CRSIOfNameP a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (CRSIOfNamePl a1 b1 c1 , CRSIOfNamePl a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FPathSearchForFile a1 b1 , FPathSearchForFile a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (FPathForAST a1 b1 c1 d1 , FPathForAST a2 b2 c2 d2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2] (ImportsOfNamePl a1 b1 c1 , ImportsOfNamePl a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ImportsRecursiveWithImpsP a1 b1 c1 d1 , ImportsRecursiveWithImpsP a2 b2 c2 d2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2] (ImportsRecursiveOfNameP a1 b1 c1 , ImportsRecursiveOfNameP a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ActualModNm a1 , ActualModNm a2 ) -> a1 `compare` a2 (BuildPlanPMb a1 b1 c1 , BuildPlanPMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ASTBuildPlanChoicePMb a1 b1 c1 , ASTBuildPlanChoicePMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (EcuOf a1 , EcuOf a2 ) -> a1 `compare` a2 (EcuOfPrevNameAndPath a1 , EcuOfPrevNameAndPath a2 ) -> a1 `compare` a2 (EHCOptsOf a1 , EHCOptsOf a2 ) -> a1 `compare` a2 (ASTRefFromFileEither a1 b1 c1 d1 e1 f1 , ASTRefFromFileEither a2 b2 c2 d2 e2 f2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2, e1 `compare` e2, f1 `compare` f2] (ASTFromFile a1 b1 c1 d1 e1 , ASTFromFile a2 b2 c2 d2 e2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2, e1 `compare` e2] (ASTP a1 b1 c1 , ASTP a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ASTPMb a1 b1 c1 , ASTPMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ASTPlMb a1 b1 c1 , ASTPlMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (ModfTimeOfFile a1 b1 c1 d1 , ModfTimeOfFile a2 b2 c2 d2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2] (ASTFileIsValid a1 b1 c1 d1 , ASTFileIsValid a2 b2 c2 d2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2, d1 `compare` d2] (ASTFileIsNewerThan a1 b1 , ASTFileIsNewerThan a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (DirOfModIsWriteable a1 b1 , DirOfModIsWriteable a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (CanCompile a1 , CanCompile a2 ) -> a1 `compare` a2 (IsTopMod a1 , IsTopMod a2 ) -> a1 `compare` a2 (HasMain a1 b1 c1 , HasMain a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldHsMod a1 b1 , FoldHsMod a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (ModnameAndImportsPlMb a1 b1 , ModnameAndImportsPlMb a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (HsModnameAndImports a1 , HsModnameAndImports a2 ) -> a1 `compare` a2 (FoldHIInfo a1 , FoldHIInfo a2 ) -> a1 `compare` a2 (ImportNameInfo a1 b1 , ImportNameInfo a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (ImportExportImpl a1 b1 , ImportExportImpl a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (FoldHsPMb a1 b1 c1 , FoldHsPMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldHsPlMb a1 b1 c1 , FoldHsPlMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldEHPMb a1 b1 c1 , FoldEHPMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldEHPlMb a1 b1 c1 , FoldEHPlMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldCoreModPlMb a1 b1 , FoldCoreModPlMb a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (FoldCore2CoreRunPlMb a1 b1 c1 , FoldCore2CoreRunPlMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FoldCoreRunModPlMb a1 b1 , FoldCoreRunModPlMb a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (FoldCoreRunCheckPlMb a1 b1 c1 , FoldCoreRunCheckPlMb a2 b2 c2 ) -> lexico [a1 `compare` a2, b1 `compare` b2, c1 `compare` c2] (FPathPreprocessedWithCPP a1 b1 , FPathPreprocessedWithCPP a2 b2 ) -> lexico [a1 `compare` a2, b1 `compare` b2] (ExposedPackages , ExposedPackages ) -> EQ where lexico = orderingLexicList instance Ord (BFun' m res) where compare = bfunCompare deriving instance Eq (BFun' m res) deriving instance Show (BFun' m res) deriving instance Typeable BFun' instance Hashable (BFun' m res) where hashWithSalt salt x = case x of CRSI -> salt `hashWithSalt` (maxBound-1::Int) CRSIWithCompileOrderPl a b c -> salt `hashWithSalt` (0::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c CRSIWithImpsPl a b c d -> salt `hashWithSalt` (1::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d CRSIOfNameP a b c -> salt `hashWithSalt` (3::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c CRSIOfNamePl a b c -> salt `hashWithSalt` (4::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FPathSearchForFile a b -> salt `hashWithSalt` (5::Int) `hashWithSalt` a `hashWithSalt` b FPathForAST a b c d -> salt `hashWithSalt` (6::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d ImportsOfNamePl a b c -> salt `hashWithSalt` (7::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ImportsRecursiveWithImpsP a b c d -> salt `hashWithSalt` (8::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d ImportsRecursiveOfNameP a b c -> salt `hashWithSalt` (9::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ActualModNm a -> salt `hashWithSalt` (10::Int) `hashWithSalt` a BuildPlanPMb a b c -> salt `hashWithSalt` (11::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ASTBuildPlanChoicePMb a b c -> salt `hashWithSalt` (11::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c EcuOf a -> salt `hashWithSalt` (12::Int) `hashWithSalt` a EHCOptsOf a -> salt `hashWithSalt` (14::Int) `hashWithSalt` a EcuOfPrevNameAndPath a -> salt `hashWithSalt` (15::Int) `hashWithSalt` a ASTRefFromFileEither a b c d e f -> salt `hashWithSalt` (18::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f ASTFromFile a b c d e -> salt `hashWithSalt` (19::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e ASTP a b c -> salt `hashWithSalt` (20::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ASTPMb a b c -> salt `hashWithSalt` (21::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ASTPlMb a b c -> salt `hashWithSalt` (22::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c ModfTimeOfFile a b c d -> salt `hashWithSalt` (23::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d ASTFileIsValid a b c d -> salt `hashWithSalt` (24::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d ASTFileIsNewerThan a b -> salt `hashWithSalt` (25::Int) `hashWithSalt` a `hashWithSalt` b DirOfModIsWriteable a b -> salt `hashWithSalt` (26::Int) `hashWithSalt` a `hashWithSalt` b CanCompile a -> salt `hashWithSalt` (27::Int) `hashWithSalt` a IsTopMod a -> salt `hashWithSalt` (29::Int) `hashWithSalt` a HasMain a b c -> salt `hashWithSalt` (29::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldHsMod a b -> salt `hashWithSalt` (30::Int) `hashWithSalt` a `hashWithSalt` b ModnameAndImportsPlMb a b -> salt `hashWithSalt` (33::Int) `hashWithSalt` a `hashWithSalt` b HsModnameAndImports a -> salt `hashWithSalt` (34::Int) `hashWithSalt` a FoldHIInfo a -> salt `hashWithSalt` (35::Int) `hashWithSalt` a ImportNameInfo a b -> salt `hashWithSalt` (37::Int) `hashWithSalt` a `hashWithSalt` b ImportExportImpl a b -> salt `hashWithSalt` (36::Int) `hashWithSalt` a `hashWithSalt` b FoldHsPMb a b c -> salt `hashWithSalt` (38::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldHsPlMb a b c -> salt `hashWithSalt` (39::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldEHPMb a b c -> salt `hashWithSalt` (40::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldEHPlMb a b c -> salt `hashWithSalt` (41::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldCoreModPlMb a b -> salt `hashWithSalt` (42::Int) `hashWithSalt` a `hashWithSalt` b FoldCore2CoreRunPlMb a b c -> salt `hashWithSalt` (44::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FoldCoreRunModPlMb a b -> salt `hashWithSalt` (45::Int) `hashWithSalt` a `hashWithSalt` b FoldCoreRunCheckPlMb a b c -> salt `hashWithSalt` (46::Int) `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c FPathPreprocessedWithCPP a b -> salt `hashWithSalt` (47::Int) `hashWithSalt` a `hashWithSalt` b ExposedPackages -> salt `hashWithSalt` (maxBound-2::Int) {-# LINE 754 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | BFun' used as a dependency of another BFun', for now same as a Dynamic data BFun m = forall res . ({- Typeable (BFun' res), -} Typeable res) => BFun { bfcdFun :: !(BFun' m res) } instance Eq (BFun m) where (BFun {bfcdFun=f1}) == (BFun {bfcdFun=f2}) = bfunCompare f1 f2 == EQ instance Ord (BFun m) where (BFun {bfcdFun=f1}) `compare` (BFun {bfcdFun=f2}) = bfunCompare f1 f2 instance Hashable (BFun m) where hashWithSalt salt (BFun {bfcdFun=x}) = hashWithSalt salt x instance Show (BFun m) where show (BFun {bfcdFun=x}) = show x {-# LINE 776 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | BFun' + BCachedVal' packaged with required class instances, similar to a Dynamic data BFunCacheEntry m = forall f res . (Typeable f, Typeable res) => BFunCacheEntry { bfceFun :: !(BFun' m res) , bfceVal :: !(f res) } {-# LINE 787 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Cache for function calls, first indexed on hash data BCache m = BCache { _bcacheCache :: IMap.IntMap [BFunCacheEntry m] , _bcacheModNmForward :: Map.Map HsName HsName , _bcacheDpdRel :: Rel.Rel (BFun m) (BFun m) } emptyBCache :: BCache m emptyBCache = BCache IMap.empty Map.empty Rel.empty {-# LINE 800 "src/ehc/EHC/CompileRun/Base.chs" #-} bcacheResolveModNm :: BCache m -> HsName -> HsName bcacheResolveModNm c n = maybe n (bcacheResolveModNm c) $ Map.lookup n (_bcacheModNmForward c) {-# LINE 809 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | GADT for references to global state, interpreted inside the compiler driver monad, the type of the GADT telling what the type of the value should be. data BRef (m :: * -> *) val where --- | Global state BRef_CRSI :: BRef m (EHCompileRunStateInfo m) --- | Global info: exposed packages BRef_ExposedPackages :: BRef m [PkgModulePartition] --- | Compile unit BRef_ECU :: !HsName --- ^ module name -> BRef m EHCompileUnit --- | An AST embedded in a compile unit directly taken from a file BRef_ASTFile :: !PrevFileSearchKey --- ^ module name -> ASTType --- ^ content type -> ASTSuffixKey --- ^ suffix and content variation -> ASTFileTiming --- ^ timing (i.e. previous or current) -> BRef m val --- | An AST embedded in a compile unit either directly taken from a file or derived by other means BRef_AST :: !PrevFileSearchKey --- ^ module name -> ASTType --- ^ content type -> BRef m val --- | Global options BRef_EHCOpts :: !HsName --- ^ module name -> BRef m EHCOpts deriving instance Typeable BRef deriving instance Show (BRef m val) {-# LINE 871 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Result coming out of a build call for constructing/loading an AST data ASTResult m ast = ASTResult { _astresAST :: ast , _astresRef :: BRef m ast , _astresPipe :: ASTPipe , _astresTimeStamp :: ClockTime } deriving (Typeable, Show) {-# LINE 885 "src/ehc/EHC/CompileRun/Base.chs" #-} mkASTResult' :: EHCCompileRunner m => ast -> BRef m ast -> ASTPipe -> Maybe ClockTime -> EHCompilePhaseT m (ASTResult m ast) mkASTResult' ast ref astpipe mbTm = do tm <- maybe (liftIO getClockTime) return mbTm return $ ASTResult ast ref astpipe tm {-# LINE 909 "src/ehc/EHC/CompileRun/Base.chs" #-} mkASTResult :: EHCCompileRunner m => ast -> BRef m ast -> ASTPipe -> EHCompilePhaseT m (ASTResult m ast) mkASTResult ast ref astpipe = mkASTResult' ast ref astpipe Nothing {-# LINE 918 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Cache for function calls, first indexed on hash data BState m = BState { _bstateCache :: !(BCache m) , _bstateCallStack :: ![BFun m] } emptyBState :: BState m emptyBState = BState emptyBCache [] {-# LINE 934 "src/ehc/EHC/CompileRun/Base.chs" #-} data EHCIOInfo = EHCIOInfo { ehcioinfoStartTime :: EHCTime , ehcioinfoLastTime :: EHCTime } {-# LINE 946 "src/ehc/EHC/CompileRun/Base.chs" #-} type EHCTime = Integer {-# LINE 954 "src/ehc/EHC/CompileRun/Base.chs" #-} data EHCompileRunCoreRunStateInfo = EHCompileRunCoreRunStateInfo { _crcrsiReqdModules :: [HsName] -- ^ (current) required/to-be-loaded modules, the length is used to assign module nr identifications , _crcrsiNm2RefMp :: !CoreRun.Nm2RefMp -- ^ current inh attrs for CoreRun semantics } emptyEHCompileRunCoreRunStateInfo :: EHCompileRunCoreRunStateInfo emptyEHCompileRunCoreRunStateInfo = EHCompileRunCoreRunStateInfo { _crcrsiReqdModules = [] , _crcrsiNm2RefMp = CoreRun.emptyNm2RefMp } {-# LINE 973 "src/ehc/EHC/CompileRun/Base.chs" #-} data EHCompileRunStateInfo (m :: * -> *) = EHCompileRunStateInfo { _crsiOpts :: !EHCOpts -- options , _crsiASTPipe :: !ASTPipe -- the compiler pipeline (based on options) , _crsiNextUID :: !UID -- unique id, the next one , _crsiHereUID :: !UID -- unique id, the current one , _crsiHSInh :: !AST_HS_Inh_Check -- current inh attrs for HS sem , _crsiEHInh :: !AST_EH_Inh_Check -- current inh attrs for EH sem , _crsiFileSuffMp :: FileSuffMp -- allowed suffixes , _crsiCEnv :: CEnv -- globally required codegen info -- 20151009 AD: TBD, for now non strict field , _crsiCoreRunState :: !EHCompileRunCoreRunStateInfo -- corerun compilation specific state -- , _crsiCore2RunInh:: !CoreRun.Nm2RefMp -- current inh attrs for Core2CoreRun sem , crsiMbMainNm :: !(Maybe HsName) -- name of main module, if any , crsiHSModInh :: !HSSemMod.Inh_AGItf -- current inh attrs for HS module analysis sem , crsiModMp :: !ModMp -- import/export info for modules , crsiGrpMp :: (Map.Map HsName EHCompileGroup) -- not yet used, for mut rec modules , crsiOptim :: !Optim -- inter module optimisation info , crsiModOffMp :: !VA.HsName2FldMpMp -- mapping of all modules + exp entries to offsets in module + exp tables , crsiEHCIOInfo :: !(IORef EHCIOInfo) -- unsafe info , crsiFilesToRm :: ![FPath] -- files to clean up (remove) , _crsiBState :: !(BState m) -- Build state for use of build functions } deriving (Typeable) {-# LINE 1008 "src/ehc/EHC/CompileRun/Base.chs" #-} emptyEHCompileRunStateInfo :: EHCompileRunStateInfo m emptyEHCompileRunStateInfo = EHCompileRunStateInfo { _crsiOpts = defaultEHCOpts , _crsiASTPipe = emptyASTPipe , _crsiNextUID = uidStart , _crsiHereUID = uidStart , _crsiHSInh = panic "emptyEHCompileRunStateInfo.crsiHSInh" , _crsiEHInh = panic "emptyEHCompileRunStateInfo.crsiEHInh" , _crsiFileSuffMp = emptyFileSuffMp , _crsiCEnv = emptyCEnv , _crsiCoreRunState = emptyEHCompileRunCoreRunStateInfo -- , _crsiCore2RunInh= panic "emptyEHCompileRunStateInfo.crsiCoreRunInh" , crsiMbMainNm = Nothing , crsiHSModInh = panic "emptyEHCompileRunStateInfo.crsiHSModInh" , crsiModMp = Map.empty , crsiGrpMp = Map.empty , crsiOptim = defaultOptim , crsiModOffMp = Map.empty , crsiEHCIOInfo = panic "emptyEHCompileRunStateInfo.crsiEHCIOInfo" , crsiFilesToRm = [] , _crsiBState = emptyBState } {-# LINE 1046 "src/ehc/EHC/CompileRun/Base.chs" #-} instance Show (EHCompileRunStateInfo m) where show _ = "EHCompileRunStateInfo" instance PP (EHCompileRunStateInfo m) where pp i = "CRSI:" >#< ppModMp (crsiModMp i) {-# LINE 1054 "src/ehc/EHC/CompileRun/Base.chs" #-} instance CompileRunStateInfo (EHCompileRunStateInfo m) HsName () where crsiImportPosOfCUKey n i = () {-# LINE 1059 "src/ehc/EHC/CompileRun/Base.chs" #-} class ( MonadIO m , MonadFix m , Typeable m -- , MonadIO (EHCompilePhaseAddonT m) , CompileRunner FileSuffInitState HsName () FileLoc EHCompileUnit (EHCompileRunStateInfo m) Err (EHCompilePhaseAddonT m) ) => EHCCompileRunner m where instance ( CompileRunStateInfo (EHCompileRunStateInfo m) HsName () , CompileUnit EHCompileUnit HsName FileLoc FileSuffInitState , CompileRunError Err () -- , MonadError (CompileRunState Err) m -- , MonadState EHCompileRun (EHCompilePhaseAddonT m) , MonadIO m , MonadFix m , Typeable m -- , MonadIO (EHCompilePhaseAddonT m) , Monad m ) => CompileRunner FileSuffInitState HsName () FileLoc EHCompileUnit (EHCompileRunStateInfo m) Err (EHCompilePhaseAddonT m) instance ( CompileRunStateInfo (EHCompileRunStateInfo m) HsName () , CompileUnit EHCompileUnit HsName FileLoc FileSuffInitState , CompileRunError Err () -- , MonadError (CompileRunState Err) m -- , MonadState EHCompileRun (EHCompilePhaseAddonT m) , MonadIO m , MonadFix m , Typeable m -- , MonadIO (EHCompilePhaseAddonT m) , Monad m ) => EHCCompileRunner m {- instance (MonadState s m) => MonadState s (EHCompilePhaseAddonT m) where get = lift MS.get put = lift . MS.put instance (MonadIO m) => MonadIO (EHCompilePhaseAddonT m) where liftIO = lift . liftIO -} {-# LINE 1102 "src/ehc/EHC/CompileRun/Base.chs" #-} type EHCompileRun m = CompileRun HsName EHCompileUnit (EHCompileRunStateInfo m) Err type EHCompilePhaseAddonT m = StateT (EHCompileRun m) m type EHCompilePhaseT m = CompilePhaseT HsName EHCompileUnit (EHCompileRunStateInfo m) Err (EHCompilePhaseAddonT m) type EHCompilePhase = EHCompilePhaseT IO {-# LINE 1115 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Delayed results (too avoid too much file content inspection) data TmOfDelayedRes = TmOfDelayedRes { _tmofdresModNm :: HsName -- ^ actual module name as it appears in file , _tmofdresHasMain :: Bool -- ^ has a main , _tmofdresImpMp :: Map.Map HsName ClockTime -- ^ imports and their timestamp } deriving (Typeable) emptyTmOfDelayedRes :: TmOfDelayedRes emptyTmOfDelayedRes = TmOfDelayedRes hsnUnknown False Map.empty {-# LINE 1129 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Results coming along with 'bMkASTPMbChoice' determining which choice in the build pipe to take data TmOfRes (m :: * -> *) = TmOfRes { _tmofresChoice :: TmChoice -- ^ the choice , _tmofresIsOverr :: Bool -- ^ is this a commandline override choice , _tmofresDelayed :: EHCompilePhaseT m (Maybe TmOfDelayedRes) -- ^ subcomponent & computationally delayed info , _tmofresTm :: ClockTime -- ^ actual timestamp , _tmofresHasMain :: Bool -- ^ has main in body (not required for choice) } deriving (Typeable) emptyTmOfRes :: TmOfRes m emptyTmOfRes = TmOfRes Choice_End False (panic "emptyTmOfRes.tmofresDelayed") (panic "emptyTmOfRes.tmofresTm") False {-# LINE 1156 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''BCache {-# LINE 1160 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''BState {-# LINE 1164 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''EHCompileRunCoreRunStateInfo {-# LINE 1168 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''EHCompileRunStateInfo {-# LINE 1181 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''ASTResult {-# LINE 1188 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''TmOfDelayedRes {-# LINE 1192 "src/ehc/EHC/CompileRun/Base.chs" #-} mkLabel ''TmOfRes {-# LINE 1203 "src/ehc/EHC/CompileRun/Base.chs" #-} crBaseInfo' :: EHCompileRun m -> (EHCompileRunStateInfo m,EHCOpts) crBaseInfo' cr = (crsi,opts) where crsi = _crStateInfo cr opts = crsi ^. crsiOpts crMbBaseInfo :: HsName -> EHCompileRun m -> (Maybe EHCompileUnit, EHCompileRunStateInfo m, EHCOpts, Maybe FPath) crMbBaseInfo modNm cr = ( mbEcu ,crsi -- if any per module opts are available, use those , maybe opts id $ mbEcu >>= ecuMbOpts , fmap ecuFilePath mbEcu ) where mbEcu = crMbCU modNm cr (crsi,opts) = crBaseInfo' cr crBaseInfo :: HsName -> EHCompileRun m -> (EHCompileUnit,EHCompileRunStateInfo m,EHCOpts,FPath) crBaseInfo modNm cr = ( maybe (panic $ "crBaseInfo.mbEcu " ++ show modNm) id mbEcu , crsi , opts , maybe (panic $ "crBaseInfo.mbFp " ++ show modNm) id mbFp ) where (mbEcu, crsi, opts, mbFp) = crMbBaseInfo modNm cr {-# LINE 1238 "src/ehc/EHC/CompileRun/Base.chs" #-} cpStepUID :: EHCCompileRunner m => EHCompilePhaseT m () cpStepUID = cpUpdSI (\crsi -> let (n,h) = mkNewLevUID (crsi ^. crsiNextUID) in crsiNextUID ^= n $ crsiHereUID ^= h $ crsi -- crsi {_crsiNextUID = n, _crsiHereUID = h} ) cpSetUID :: EHCCompileRunner m => UID -> EHCompilePhaseT m () cpSetUID u = cpUpdSI $ crsiNextUID ^= u -- (\crsi -> crsi {crsiNextUID = u}) {-# LINE 1255 "src/ehc/EHC/CompileRun/Base.chs" #-} type EHCTimeDiff = Integer getEHCTime :: IO EHCTime getEHCTime = getCPUTime ehcTimeDiff :: EHCTime -> EHCTime -> EHCTimeDiff ehcTimeDiff = (-) ehcTimeDiffFmt :: EHCTimeDiff -> String ehcTimeDiffFmt t = fm 2 hrs ++ ":" ++ fm 2 mins ++ ":" ++ fm 2 secs ++ ":" ++ fm 6 (psecs `div` 1000000) where (r0 , psecs) = t `quotRem` 1000000000000 (r1 , secs ) = r0 `quotRem` 60 (r2 , mins ) = r1 `quotRem` 60 (days, hrs ) = r2 `quotRem` 24 fm n x = strPadLeft '0' n (show x) {-# LINE 1278 "src/ehc/EHC/CompileRun/Base.chs" #-} cpRegisterFilesToRm :: EHCCompileRunner m => [FPath] -> EHCompilePhaseT m () cpRegisterFilesToRm fpL = cpUpdSI (\crsi -> crsi {crsiFilesToRm = fpL ++ crsiFilesToRm crsi}) {-# LINE 1284 "src/ehc/EHC/CompileRun/Base.chs" #-} cpRmFilesToRm :: EHCCompileRunner m => EHCompilePhaseT m () cpRmFilesToRm = do { cr <- MS.get ; let (crsi,opts) = crBaseInfo' cr files = Set.toList $ Set.fromList $ map fpathToStr $ crsiFilesToRm crsi ; liftIO $ mapM rm files ; cpUpdSI (\crsi -> crsi {crsiFilesToRm = []}) } where rm f = CE.catch (removeFile f) (\(e :: SomeException) -> hPutStrLn stderr (show f ++ ": " ++ show e)) {-# LINE 1301 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Tracing cpTrPP :: EHCCompileRunner m => TraceOn -> [PP_Doc] -> EHCompilePhaseT m () cpTrPP ton ms = do cr <- MS.get let (_,opts) = crBaseInfo' cr trOnPP (`Set.member` ehcOptTraceOn opts) ton ms {- when (ton `elem` ehcOptTraceOn opts) $ liftIO $ pr ms where pr [] = return () pr [m] = putPPLn $ show ton >|< ":" >#< m pr (m:ms) = do pr [m] forM_ ms $ \m -> putPPLn $ indent 2 m -} -- | Tracing cpTr :: EHCCompileRunner m => TraceOn -> [String] -> EHCompilePhaseT m () cpTr ton ms = cpTrPP ton $ map pp ms {-# LINE 1325 "src/ehc/EHC/CompileRun/Base.chs" #-} cpMemUsage :: EHCCompileRunner m => EHCompilePhaseT m () cpMemUsage = return () {-# LINE 1344 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Message cpMsg :: EHCCompileRunner m => HsName -> Verbosity -> String -> EHCompilePhaseT m () cpMsg modNm v m = do { cr <- MS.get ; let (_,_,_,mbFp) = crMbBaseInfo modNm cr ; cpMsg' modNm v m Nothing (maybe emptyFPath id mbFp) } cpMsg' :: EHCCompileRunner m => HsName -> Verbosity -> String -> Maybe String -> FPath -> EHCompilePhaseT m () cpMsg' modNm v m mbInfo fp = do { cr <- MS.get ; let (mbEcu,crsi,opts,_) = crMbBaseInfo modNm cr ; ehcioinfo <- liftIO $ readIORef (crsiEHCIOInfo crsi) ; clockTime <- liftIO getEHCTime ; let clockStartTimePrev = ehcioinfoStartTime ehcioinfo clockTimePrev = ehcioinfoLastTime ehcioinfo clockStartTimeDiff = ehcTimeDiff clockTime clockStartTimePrev clockTimeDiff = ehcTimeDiff clockTime clockTimePrev ; let t = if v >= VerboseALot then "<" ++ strBlankPad 35 (ehcTimeDiffFmt clockStartTimeDiff ++ "/" ++ ehcTimeDiffFmt clockTimeDiff) ++ ">" else "" m' = maybe "" (\ecu -> show (ecuSeqNr ecu) ++ t ++ " ") mbEcu ++ m ; liftIO $ putCompileMsg v (ehcOptVerbosity opts) m' mbInfo modNm fp ; clockTime <- liftIO getEHCTime ; liftIO $ writeIORef (crsiEHCIOInfo crsi) (ehcioinfo {ehcioinfoLastTime = clockTime}) -- ; cpUpdSI (\crsi -> crsi { crsiTime = clockTime }) ; cpMemUsage } {-# LINE 1386 "src/ehc/EHC/CompileRun/Base.chs" #-} cpSystem' :: EHCCompileRunner m => Maybe FilePath -> (FilePath,[String]) -> EHCompilePhaseT m () cpSystem' mbStdOut (cmd,args) = do { exitCode <- liftIO $ system $ showShellCmd $ (cmd,args ++ (maybe [] (\o -> [">", o]) mbStdOut)) ; case exitCode of ExitSuccess -> return () _ -> cpSetFail } cpSystem :: EHCCompileRunner m => (FilePath,[String]) -> EHCompilePhaseT m () cpSystem = cpSystem' Nothing {-# LINE 1416 "src/ehc/EHC/CompileRun/Base.chs" #-} cpSystemRaw :: EHCCompileRunner m => String -> [String] -> EHCompilePhaseT m () cpSystemRaw cmd args = do { exitCode <- liftIO $ rawSystem cmd args ; case exitCode of ExitSuccess -> return () _ -> cpSetErrs [rngLift emptyRange Err_PP $ pp $ show exitCode] -- cpSetFail } {-# LINE 1430 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | split module names in those part of a package, and others crPartitionIntoPkgAndOthers :: EHCompileRun m -> [HsName] -> ([PkgModulePartition],[HsName]) crPartitionIntoPkgAndOthers cr modNmL = ( [ (p,d,m) | ((p,d),m) <- Map.toList $ Map.unionsWith (++) $ map Map.fromList ps ] , concat ms ) where (ps,ms) = unzip $ map loc modNmL loc m = case filelocKind $ ecuFileLocation ecu of FileLocKind_Dir -> ([ ], [m]) FileLocKind_Pkg p d -> ([((p,d),[m])], [ ]) where (ecu,_,_,_) = crBaseInfo m cr {-# LINE 1450 "src/ehc/EHC/CompileRun/Base.chs" #-} crsiExpNmOffMpDbg :: String -> HsName -> EHCompileRunStateInfo m -> VA.HsName2FldMp crsiExpNmOffMpDbg ctxt modNm crsi = mmiNmOffMp $ panicJust ("crsiExpNmOffMp." ++ ctxt ++ show ks ++ ": " ++ show modNm) $ Map.lookup modNm $ crsiModMp crsi where ks = Map.keys $ crsiModMp crsi crsiExpNmOffMp :: HsName -> EHCompileRunStateInfo m -> VA.HsName2FldMp crsiExpNmOffMp modNm crsi = mmiNmOffMp $ panicJust ("crsiExpNmOffMp: " ++ show modNm) $ Map.lookup modNm $ crsiModMp crsi {-# LINE 1463 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Add ast types for which the semantics have been flowed into global state, with additional from/to info bUpdAlreadyFlowIntoCRSIWith :: EHCCompileRunner m => HsName -> ASTType -> ASTAlreadyFlowIntoCRSIInfo -> EHCompilePhaseT m () bUpdAlreadyFlowIntoCRSIWith modNm asttype flowstage = bUpdECU modNm $ ecuAlreadyFlowIntoCRSI ^$= Map.insertWith Set.union asttype (Set.singleton flowstage) -- | Add ast types for which the semantics have been flowed into global state bUpdAlreadyFlowIntoCRSI :: EHCCompileRunner m => HsName -> ASTType -> ASTSemFlowStage -> EHCompilePhaseT m () bUpdAlreadyFlowIntoCRSI modNm asttype flowstage = bUpdAlreadyFlowIntoCRSIWith modNm asttype (flowstage,Nothing) {-# LINE 1479 "src/ehc/EHC/CompileRun/Base.chs" #-} -- | Lookup compile unit, also giving the actual module name forwarded to bLookupECUInCR :: HsName -> EHCompileRun m -> Maybe (HsName, EHCompileUnit) bLookupECUInCR n cr = lkn n <|> lkn (bcacheResolveModNm (cr ^. crStateInfo ^. crsiBState ^. bstateCache) n) where lkn n = fmap ((,) n) $ crMbCU n cr -- | Lookup compile unit, also giving the actual module name forwarded to bLookupECU' :: EHCCompileRunner m => HsName -> EHCompilePhaseT m (Maybe (HsName, EHCompileUnit)) bLookupECU' n = MS.gets (bLookupECUInCR n) -- | Lookup compile unit bLookupECU :: EHCCompileRunner m => HsName -> EHCompilePhaseT m (Maybe EHCompileUnit) bLookupECU n = fmap (fmap snd) $ bLookupECU' n -- | Update compile unit bUpdECU :: EHCCompileRunner m => HsName -> (EHCompileUnit -> EHCompileUnit) -> EHCompilePhaseT m () bUpdECU n f = do cr <- MS.get cpUpdCU (maybe n fst $ bLookupECUInCR n cr) f {-# LINE 1504 "src/ehc/EHC/CompileRun/Base.chs" #-} -- type TmOfRes m = TmRes m -- (EHCompilePhaseT m (Maybe (Map.Map HsName ClockTime)), TmChoice, ClockTime) type TmOfResMb m = Maybe (TmOfRes m) type TmOfResM m = EHCompilePhaseT m (TmOfResMb m) -- updTmChoice upd = \(imps,ch,tm) -> (imps,upd ch,tm) updTmChoice upd = tmofresChoice ^$= upd updTmChoiceM upd = fmap (fmap (updTmChoice upd))