uhc-light-1.1.8.10: src/UHC/Light/Compiler/EHC/CompileRun.hs
{-# LANGUAGE TemplateHaskell #-}
module UHC.Light.Compiler.EHC.CompileRun
( EHCompileRunStateInfo (..)
, crsiOpts, crsiNextUID, crsiHereUID, crsiHSInh, crsiEHInh, crsiBState, crsiFileSuffMp
, emptyEHCompileRunStateInfo
, EHCCompileRunner
, EHCompileRun, EHCompilePhaseT, EHCompilePhase
, crBaseInfo, crMbBaseInfo, crBaseInfo'
, cpUpdOpts
, cpMsg, cpMsg'
, cpStepUID, cpSetUID
, cpSystem', cpSystem
, cpSystemRaw
, cpStopAt
, crsiExpNmOffMpDbg, crsiExpNmOffMp
, crPartitionMainAndImported
, crModNeedsCompile
, 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 hiding (get)
import qualified Control.Monad.State as MS
import Control.Monad.Error
import Control.Exception as CE
import UHC.Util.Lens
import UHC.Light.Compiler.CodeGen.ValAccess as VA
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.EHC.FileSuffMp
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.BuildFunction
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 82 "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 102 "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 136 "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
, _crsiFileSuffMp :: FileSuffMp -- allowed suffixes
, 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)
, _crsiBState :: !BState -- Build state for use of build functions
}
{-# LINE 169 "src/ehc/EHC/CompileRun.chs" #-}
mkLabel ''EHCompileRunStateInfo
{-# LINE 173 "src/ehc/EHC/CompileRun.chs" #-}
emptyEHCompileRunStateInfo :: EHCompileRunStateInfo
emptyEHCompileRunStateInfo
= EHCompileRunStateInfo
{ _crsiOpts = defaultEHCOpts
, _crsiNextUID = uidStart
, _crsiHereUID = uidStart
, _crsiHSInh = panic "emptyEHCompileRunStateInfo.crsiHSInh"
, _crsiEHInh = panic "emptyEHCompileRunStateInfo.crsiEHInh"
, _crsiFileSuffMp = emptyFileSuffMp
, 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 = []
, _crsiBState = emptyBState
}
{-# LINE 207 "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 216 "src/ehc/EHC/CompileRun.chs" #-}
instance Show EHCompileRunStateInfo where
show _ = "EHCompileRunStateInfo"
instance PP EHCompileRunStateInfo where
pp i = "CRSI:" >#< ppModMp (crsiModMp i)
{-# LINE 224 "src/ehc/EHC/CompileRun.chs" #-}
instance CompileRunStateInfo EHCompileRunStateInfo HsName () where
crsiImportPosOfCUKey n i = ()
{-# LINE 229 "src/ehc/EHC/CompileRun.chs" #-}
class (MonadIO m, CompileRunner FileSuffInitState HsName () FileLoc EHCompileUnit EHCompileRunStateInfo Err (EHCompilePhaseAddonT m)) => EHCCompileRunner m where
instance ( CompileRunStateInfo EHCompileRunStateInfo HsName ()
, CompileUnit EHCompileUnit HsName FileLoc FileSuffInitState
, CompileRunError Err ()
-- , MonadError (CompileRunState Err) m
-- , MonadState EHCompileRun (EHCompilePhaseAddonT m)
, MonadIO m -- (EHCompilePhaseAddonT m)
, Monad m
) => CompileRunner FileSuffInitState HsName () FileLoc EHCompileUnit EHCompileRunStateInfo Err (EHCompilePhaseAddonT m)
instance ( CompileRunStateInfo EHCompileRunStateInfo HsName ()
, CompileUnit EHCompileUnit HsName FileLoc FileSuffInitState
, CompileRunError Err ()
-- , MonadError (CompileRunState Err) m
-- , MonadState EHCompileRun (EHCompilePhaseAddonT m)
, MonadIO m -- (EHCompilePhaseAddonT m)
, Monad m
) => EHCCompileRunner m
{-# LINE 251 "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 263 "src/ehc/EHC/CompileRun.chs" #-}
crBaseInfo' :: EHCompileRun -> (EHCompileRunStateInfo,EHCOpts)
crBaseInfo' cr
= (crsi,opts)
where crsi = _crStateInfo cr
opts = crsi ^. crsiOpts
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 298 "src/ehc/EHC/CompileRun.chs" #-}
cpMemUsage :: EHCCompileRunner m => EHCompilePhaseT m ()
cpMemUsage
= return ()
{-# LINE 321 "src/ehc/EHC/CompileRun.chs" #-}
cpUpdOpts :: EHCCompileRunner m => (EHCOpts -> EHCOpts) -> EHCompilePhaseT m ()
cpUpdOpts upd
= cpUpdSI $ crsiOpts ^$= upd -- (\crsi -> crsi {crsiOpts = upd $ crsiOpts crsi})
{-# LINE 331 "src/ehc/EHC/CompileRun.chs" #-}
cpRegisterFilesToRm :: EHCCompileRunner m => [FPath] -> EHCompilePhaseT m ()
cpRegisterFilesToRm fpL
= cpUpdSI (\crsi -> crsi {crsiFilesToRm = fpL ++ crsiFilesToRm crsi})
{-# LINE 337 "src/ehc/EHC/CompileRun.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 354 "src/ehc/EHC/CompileRun.chs" #-}
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 395 "src/ehc/EHC/CompileRun.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 412 "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 442 "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 456 "src/ehc/EHC/CompileRun.chs" #-}
cpStopAt :: EHCCompileRunner m => CompilePoint -> EHCompilePhaseT m ()
cpStopAt atPhase
= do { cr <- MS.get
; let (_,opts) = crBaseInfo' cr
; unless (atPhase < ehcStopAtPoint opts)
cpSetStopAllSeq
}
{-# LINE 470 "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 487 "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 497 "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 = _crStateInfo cr ^. crsiOpts
{-# LINE 529 "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 549 "src/ehc/EHC/CompileRun.chs" #-}
crSetAndCheckMain :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
crSetAndCheckMain modNm
= do { cr <- MS.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 []
}