module UHC.Light.Compiler.EHC.CompileRun ( EHCompileRunStateInfo (..) , emptyEHCompileRunStateInfo , EHCCompileRunner , EHCompileRun, EHCompilePhaseT, EHCompilePhase , crBaseInfo, crMbBaseInfo, crBaseInfo' , cpUpdOpts , cpMsg, cpMsg' , cpStepUID, cpSetUID , cpSystem', cpSystem , cpSystemRaw , cpStopAt , crsiExpNmOffMpDbg, crsiExpNmOffMp , crPartitionMainAndImported , crModNeedsCompile , crModCanCompile , crSetAndCheckMain , EHCTime, EHCTimeDiff, getEHCTime, ehcTimeDiff, ehcTimeDiffFmt , EHCIOInfo (..), newEHCIOInfo , cpRegisterFilesToRm , cpRmFilesToRm , crPartitionIntoPkgAndOthers ) where import qualified Data.Map as Map import qualified Data.Set as Set import System.IO import System.Exit import System.Environment import System.Process import Control.Monad.State import Control.Monad.Error import Control.Exception as CE import UHC.Light.Compiler.CodeGen.ValAccess as VA import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileUnit import qualified UHC.Light.Compiler.Core as Core import qualified UHC.Light.Compiler.CoreRun as CoreRun import qualified UHC.Light.Compiler.EH.MainAG as EHSem import qualified UHC.Light.Compiler.HS.MainAG as HSSem import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem import UHC.Light.Compiler.EHC.CompileGroup import qualified UHC.Light.Compiler.HS.ModImpExp as HSSemMod 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.Light.Compiler.Base.PackageDatabase {-# LINE 71 "src/ehc/EHC/CompileRun.chs" #-} type EHCTime = Integer 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 91 "src/ehc/EHC/CompileRun.chs" #-} data EHCIOInfo = EHCIOInfo { ehcioinfoStartTime :: EHCTime , ehcioinfoLastTime :: EHCTime } newEHCIOInfo :: IO (IORef EHCIOInfo) newEHCIOInfo = do t <- getEHCTime newIORef (EHCIOInfo t t) {-# LINE 125 "src/ehc/EHC/CompileRun.chs" #-} data EHCompileRunStateInfo = EHCompileRunStateInfo { crsiOpts :: !EHCOpts -- options , crsiNextUID :: !UID -- unique id, the next one , crsiHereUID :: !UID -- unique id, the current one , crsiHSInh :: !HSSem.Inh_AGItf -- current inh attrs for HS sem , crsiEHInh :: !EHSem.Inh_AGItf -- current inh attrs for EH sem , crsiCoreInh :: !Core2GrSem.Inh_CodeAGItf -- current inh attrs for Core2Grin sem , 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) } {-# LINE 156 "src/ehc/EHC/CompileRun.chs" #-} emptyEHCompileRunStateInfo :: EHCompileRunStateInfo emptyEHCompileRunStateInfo = EHCompileRunStateInfo { crsiOpts = defaultEHCOpts , crsiNextUID = uidStart , crsiHereUID = uidStart , crsiHSInh = panic "emptyEHCompileRunStateInfo.crsiHSInh" , crsiEHInh = panic "emptyEHCompileRunStateInfo.crsiEHInh" , crsiCoreInh = panic "emptyEHCompileRunStateInfo.crsiCoreInh" , 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 = [] } {-# LINE 188 "src/ehc/EHC/CompileRun.chs" #-} crsiExpNmOffMpDbg :: String -> HsName -> EHCompileRunStateInfo -> 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 -> VA.HsName2FldMp crsiExpNmOffMp modNm crsi = mmiNmOffMp $ panicJust ("crsiExpNmOffMp: " ++ show modNm) $ Map.lookup modNm $ crsiModMp crsi {-# LINE 197 "src/ehc/EHC/CompileRun.chs" #-} instance Show EHCompileRunStateInfo where show _ = "EHCompileRunStateInfo" instance PP EHCompileRunStateInfo where pp i = "CRSI:" >#< ppModMp (crsiModMp i) {-# LINE 205 "src/ehc/EHC/CompileRun.chs" #-} instance CompileRunStateInfo EHCompileRunStateInfo HsName () where crsiImportPosOfCUKey n i = () {-# LINE 210 "src/ehc/EHC/CompileRun.chs" #-} class (MonadIO m, CompileRunner EHCompileUnitState HsName () FileLoc EHCompileUnit EHCompileRunStateInfo Err (EHCompilePhaseAddonT m)) => EHCCompileRunner m where instance ( CompileRunStateInfo EHCompileRunStateInfo HsName () , CompileUnit EHCompileUnit HsName FileLoc EHCompileUnitState , CompileRunError Err () -- , MonadError (CompileRunState Err) m -- , MonadState EHCompileRun (EHCompilePhaseAddonT m) , MonadIO m -- (EHCompilePhaseAddonT m) , Monad m ) => CompileRunner EHCompileUnitState HsName () FileLoc EHCompileUnit EHCompileRunStateInfo Err (EHCompilePhaseAddonT m) instance ( CompileRunStateInfo EHCompileRunStateInfo HsName () , CompileUnit EHCompileUnit HsName FileLoc EHCompileUnitState , CompileRunError Err () -- , MonadError (CompileRunState Err) m -- , MonadState EHCompileRun (EHCompilePhaseAddonT m) , MonadIO m -- (EHCompilePhaseAddonT m) , Monad m ) => EHCCompileRunner m {-# LINE 232 "src/ehc/EHC/CompileRun.chs" #-} type EHCompileRun = CompileRun HsName EHCompileUnit EHCompileRunStateInfo Err type EHCompilePhaseAddonT m = StateT EHCompileRun m type EHCompilePhaseT m = CompilePhaseT HsName EHCompileUnit EHCompileRunStateInfo Err (EHCompilePhaseAddonT m) type EHCompilePhase = EHCompilePhaseT IO {-# LINE 244 "src/ehc/EHC/CompileRun.chs" #-} crBaseInfo' :: EHCompileRun -> (EHCompileRunStateInfo,EHCOpts) crBaseInfo' cr = (crsi,opts) where crsi = crStateInfo cr opts = crsiOpts crsi crMbBaseInfo :: HsName -> EHCompileRun -> (Maybe EHCompileUnit, EHCompileRunStateInfo, 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 -> (EHCompileUnit,EHCompileRunStateInfo,EHCOpts,FPath) crBaseInfo modNm cr = ( maybe (panic "crBaseInfo.mbEcu") id mbEcu , crsi , opts , maybe (panic "crBaseInfo.mbFp") id mbFp ) where (mbEcu, crsi, opts, mbFp) = crMbBaseInfo modNm cr {-# LINE 279 "src/ehc/EHC/CompileRun.chs" #-} cpMemUsage :: EHCCompileRunner m => EHCompilePhaseT m () cpMemUsage = return () {-# LINE 302 "src/ehc/EHC/CompileRun.chs" #-} cpUpdOpts :: EHCCompileRunner m => (EHCOpts -> EHCOpts) -> EHCompilePhaseT m () cpUpdOpts upd = cpUpdSI (\crsi -> crsi {crsiOpts = upd $ crsiOpts crsi}) {-# LINE 312 "src/ehc/EHC/CompileRun.chs" #-} cpRegisterFilesToRm :: EHCCompileRunner m => [FPath] -> EHCompilePhaseT m () cpRegisterFilesToRm fpL = cpUpdSI (\crsi -> crsi {crsiFilesToRm = fpL ++ crsiFilesToRm crsi}) {-# LINE 318 "src/ehc/EHC/CompileRun.chs" #-} cpRmFilesToRm :: EHCCompileRunner m => EHCompilePhaseT m () cpRmFilesToRm = do { cr <- 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 335 "src/ehc/EHC/CompileRun.chs" #-} cpMsg :: EHCCompileRunner m => HsName -> Verbosity -> String -> EHCompilePhaseT m () cpMsg modNm v m = do { cr <- 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 <- 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 376 "src/ehc/EHC/CompileRun.chs" #-} cpStepUID :: EHCCompileRunner m => EHCompilePhaseT m () cpStepUID = cpUpdSI (\crsi -> let (n,h) = mkNewLevUID (crsiNextUID crsi) in crsi {crsiNextUID = n, crsiHereUID = h} ) cpSetUID :: EHCCompileRunner m => UID -> EHCompilePhaseT m () cpSetUID u = cpUpdSI (\crsi -> crsi {crsiNextUID = u}) {-# LINE 392 "src/ehc/EHC/CompileRun.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 422 "src/ehc/EHC/CompileRun.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 436 "src/ehc/EHC/CompileRun.chs" #-} cpStopAt :: EHCCompileRunner m => CompilePoint -> EHCompilePhaseT m () cpStopAt atPhase = do { cr <- get ; let (_,opts) = crBaseInfo' cr ; unless (atPhase < ehcStopAtPoint opts) cpSetStopAllSeq } {-# LINE 450 "src/ehc/EHC/CompileRun.chs" #-} crPartitionNewerOlderImports :: HsName -> EHCompileRun -> ([EHCompileUnit],[EHCompileUnit]) crPartitionNewerOlderImports modNm cr = partition isNewer $ map (flip crCU cr) $ ecuImpNmL ecu where ecu = crCU modNm cr t = panicJust "crPartitionNewerOlderImports1" $ ecuMbHIInfoTime ecu isNewer ecu' | isJust mbt = t' `diffClockTimes` t > noTimeDiff | otherwise = False where t' = panicJust "crPartitionNewerOlderImports2" $ ecuMbHIInfoTime ecu' mbt = ecuMbHIInfoTime ecu' {-# LINE 467 "src/ehc/EHC/CompileRun.chs" #-} -- | Partition modules into main and non main (i.e. imported) module names crPartitionMainAndImported :: EHCompileRun -> [HsName] -> ([HsName], [HsName]) crPartitionMainAndImported cr modNmL = partition (\n -> ecuHasMain $ crCU n cr) modNmL {-# LINE 477 "src/ehc/EHC/CompileRun.chs" #-} crModNeedsCompile :: HsName -> EHCompileRun -> Bool crModNeedsCompile modNm cr = ecuIsMainMod ecu -- ecuIsTopMod ecu || not ( ehcOptCheckRecompile opts && ecuCanUseHIInsteadOfHS ecu && null newer ) where ecu = crCU modNm cr (newer,_) = crPartitionNewerOlderImports modNm cr opts = crsiOpts $ crStateInfo cr {-# LINE 498 "src/ehc/EHC/CompileRun.chs" #-} crModCanCompile :: HsName -> EHCompileRun -> Bool crModCanCompile modNm cr = isJust (ecuMbSrcTime ecu) && ecuDirIsWritable ecu where ecu = crCU modNm cr {-# LINE 509 "src/ehc/EHC/CompileRun.chs" #-} -- | split module names in those part of a package, and others crPartitionIntoPkgAndOthers :: EHCompileRun -> [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 529 "src/ehc/EHC/CompileRun.chs" #-} crSetAndCheckMain :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () crSetAndCheckMain modNm = do { cr <- get ; let (crsi,opts) = crBaseInfo' cr mkerr lim ns = cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MayOnlyHaveNrMain lim ns modNm] ; case crsiMbMainNm crsi of Just n | n /= modNm -> mkerr 1 [n] _ | ehcOptDoExecLinking opts -> cpUpdSI (\crsi -> crsi {crsiMbMainNm = Just modNm}) | otherwise -> return () -- mkerr 0 [] }