├── .gitignore ├── BuildModule.hs ├── ChangeLog.md ├── Compat.hs ├── GhcAction.hs ├── GhcShake.hs ├── GhcShakeInstances.hs ├── LICENSE ├── PersistentCache.hs ├── README ├── Setup.hs ├── ghc-shake ├── ghc-shake.cabal └── scraps /.gitignore: -------------------------------------------------------------------------------- 1 | ghc 2 | ghc-pkg 3 | dist 4 | dist-newstyle 5 | .shake 6 | -------------------------------------------------------------------------------- /BuildModule.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | module BuildModule ( 5 | BuildModule(..), 6 | buildModuleLocation, 7 | buildModuleLogPath, 8 | buildModuleLocations, 9 | buildModuleRule, 10 | needBuildModule, 11 | shakeDynFlags, 12 | ) where 13 | 14 | import GhcPlugins hiding ( varName, errorMsg, fatalErrorMsg ) 15 | 16 | import Maybes 17 | 18 | import GhcShakeInstances 19 | import Compat 20 | 21 | import Development.Shake 22 | import Development.Shake.Rule 23 | import Development.Shake.Classes 24 | 25 | -- I'm evil! 26 | import Development.Shake.Rules.File 27 | import Development.Shake.ByteString 28 | import General.String 29 | 30 | import Prelude hiding (mod) 31 | import GHC.Generics (Generic) 32 | import qualified Data.HashMap.Strict as HashMap 33 | import Data.Dynamic 34 | import System.FilePath 35 | 36 | -- | A 'BuildModule' is a key for module which can be built. Unlike 37 | -- in 'GhcMake', we also store the source filename (because a module 38 | -- may be implemented multiple times by different source files.) 39 | -- 40 | -- NB: the filename is ALWAYS for the non-boot version of the file. 41 | data BuildModule 42 | = BuildModule { 43 | bm_filename :: FilePath, 44 | bm_mod :: Module, 45 | bm_is_boot :: IsBoot 46 | } 47 | deriving (Show, Typeable, Eq, Generic) 48 | 49 | instance Hashable BuildModule 50 | instance Binary BuildModule 51 | instance NFData BuildModule 52 | 53 | -- | Compute the 'FilePath' which we will log warnings to. 54 | buildModuleLogPath :: DynFlags -> BuildModule -> FilePath 55 | buildModuleLogPath dflags (BuildModule file mod is_boot) = 56 | let basename = dropExtension file 57 | mod_basename = moduleNameSlashes (moduleName mod) 58 | in dropExtension (mkHiPath dflags basename mod_basename) <.> 59 | (if is_boot then "log-boot" else "log") 60 | 61 | -- | Compute the 'ModLocation' for a 'BuildModule'. 62 | buildModuleLocation :: DynFlags -> BuildModule -> ModLocation 63 | buildModuleLocation dflags (BuildModule file mod is_boot) = 64 | let basename = dropExtension file 65 | mod_basename = moduleNameSlashes (moduleName mod) 66 | maybeAddBootSuffixLocn 67 | | is_boot = addBootSuffixLocn 68 | | otherwise = id 69 | in maybeAddBootSuffixLocn 70 | $ ModLocation { 71 | ml_hs_file = Just file, 72 | ml_hi_file = mkHiPath dflags basename mod_basename, 73 | ml_obj_file = mkObjPath dflags basename mod_basename 74 | } 75 | 76 | -- | Computes the normal and the dynamic (in that order) 'ModLocation's 77 | -- of a 'BuildModule'. 78 | buildModuleLocations :: DynFlags -> BuildModule -> (ModLocation, ModLocation) 79 | buildModuleLocations dflags bm = 80 | let dyn_dflags = dynamicTooMkDynamicDynFlags dflags 81 | in (buildModuleLocation dflags bm, buildModuleLocation dyn_dflags bm) 82 | 83 | 84 | -- | An answer type for 'BuildModule' rules, tracking the file state of 85 | -- all possible files a 'BuildModule' rule may generate. 86 | data BuildModuleA = BuildModuleA 87 | { bma_hi :: Maybe FileA 88 | , bma_o :: Maybe FileA 89 | , bma_dyn_hi :: Maybe FileA 90 | , bma_dyn_o :: Maybe FileA 91 | } 92 | deriving (Eq, Generic, Typeable, Show) 93 | instance Binary BuildModuleA 94 | instance NFData BuildModuleA 95 | instance Hashable BuildModuleA 96 | 97 | 98 | -- | Recompute 'BuildModuleA' based on the state of the file system 99 | -- and what we were rebuilding this round. 100 | rebuildBuildModuleA :: ShakeOptions -> BuildModule -> IO BuildModuleA 101 | rebuildBuildModuleA opts bm = do 102 | let dflags = shakeDynFlags opts 103 | -- TODO: more sanity checking, e.g. make sure that things we 104 | -- expect were actually built 105 | r <- storedValue opts bm 106 | -- If we recompiled, we must invalidate anything we DIDN'T build 107 | -- (so the next time the are requested, we trigger a recomp.) 108 | let invalidateObj | hscTarget dflags == HscNothing = \bma -> bma { bma_o = Nothing } 109 | | otherwise = id 110 | invalidateDyn | gopt Opt_BuildDynamicToo dflags = id 111 | | otherwise = \bma -> bma { bma_dyn_hi = Nothing, bma_dyn_o = Nothing } 112 | case r of 113 | Nothing -> error "Missing compilation products" 114 | Just ans -> return (invalidateDyn (invalidateObj ans)) 115 | 116 | 117 | -- | Extract 'DynFlags' from 'ShakeOptions'. 118 | shakeDynFlags :: ShakeOptions -> DynFlags 119 | shakeDynFlags opts = 120 | case HashMap.lookup (typeRep (Proxy :: Proxy DynFlags)) (shakeExtra opts) of 121 | Nothing -> error "shakeDynFlags: not in map" 122 | Just d -> case fromDynamic d of 123 | Just dflags -> dflags 124 | Nothing -> error "shakeDynFlags: bad type" 125 | 126 | 127 | -- | Create a 'FileQ' (the question type for Shake's built-in file 128 | -- rules) from a 'FilePath'. 129 | mkFileQ :: FilePath -> FileQ 130 | mkFileQ = FileQ . packU_ . filepathNormalise . unpackU_ . packU 131 | 132 | buildModuleRule :: (BuildModule -> Action ()) -> Rules () 133 | buildModuleRule f = rule $ \bm -> Just $ do 134 | f bm 135 | opts <- getShakeOptions 136 | liftIO $ rebuildBuildModuleA opts bm 137 | 138 | -- This is similar to the Files rule, representing four files. However, 139 | -- we do not necessarily compare on ALL of them to determine whether 140 | -- or not a stored value is valid: we only compare on the files which 141 | -- we are BUILDING. 142 | instance Rule BuildModule BuildModuleA where 143 | storedValue opts bm = do 144 | let dflags = shakeDynFlags opts 145 | (loc, dyn_loc) = buildModuleLocations dflags bm 146 | mb_hi <- storedValue opts (mkFileQ (ml_hi_file loc)) 147 | mb_o <- storedValue opts (mkFileQ (ml_obj_file loc)) 148 | mb_dyn_hi <- storedValue opts (mkFileQ (ml_hi_file dyn_loc)) 149 | mb_dyn_o <- storedValue opts (mkFileQ (ml_obj_file dyn_loc)) 150 | return (Just (BuildModuleA mb_hi mb_o mb_dyn_hi mb_dyn_o)) 151 | equalValue opts bm v1 v2 = 152 | let dflags = shakeDynFlags opts 153 | (loc, dyn_loc) = buildModuleLocations dflags bm 154 | in foldr and_ EqualCheap 155 | $ [ test (mkFileQ (ml_hi_file loc)) bma_hi ] 156 | ++ if hscTarget dflags == HscNothing 157 | then [] 158 | else [ test (mkFileQ (ml_obj_file loc)) bma_o ] 159 | ++ if gopt Opt_BuildDynamicToo dflags 160 | && not (bm_is_boot bm) -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/11327#ticket 161 | then [ test (mkFileQ (ml_hi_file dyn_loc)) bma_dyn_hi 162 | , test (mkFileQ (ml_obj_file dyn_loc)) bma_dyn_o ] 163 | else [] 164 | where test k sel = case equalValue opts k <$> sel v1 <*> sel v2 of 165 | Nothing -> NotEqual 166 | Just r -> r 167 | -- Copy-pasted from Shake 168 | and_ NotEqual _ = NotEqual 169 | and_ EqualCheap x = x 170 | and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive 171 | 172 | -- | Add a dependency on a Haskell module. 173 | needBuildModule :: BuildModule -> Action () 174 | needBuildModule bm = (apply1 bm :: Action BuildModuleA) >> return () 175 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for ghc-shake 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /Compat.hs: -------------------------------------------------------------------------------- 1 | module Compat where 2 | 3 | import GhcPlugins 4 | import DriverPhases ( Phase(..) 5 | , phaseInputExt, eqPhase, isHaskellSrcFilename ) 6 | import PipelineMonad ( PipelineOutput(..) ) 7 | import SysTools ( newTempName ) 8 | import qualified Binary as B 9 | 10 | import System.FilePath 11 | 12 | ----------------------------------------------------------------------- 13 | 14 | -- COPYPASTA 15 | 16 | ----------------------------------------------------------------------- 17 | 18 | -- copypasted from ghc/Main.hs 19 | -- TODO: put this in a library 20 | haskellish :: (String, Maybe Phase) -> Bool 21 | haskellish (f,Nothing) = 22 | looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f 23 | haskellish (_,Just phase) = 24 | phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm 25 | , StopLn] 26 | 27 | -- getOutputFilename copypasted from DriverPipeline 28 | -- ToDo: uncopypaste 29 | -- Notice that StopLn output is always .o! Very useful. 30 | getOutputFilename 31 | :: Phase -> PipelineOutput -> String 32 | -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath 33 | getOutputFilename stop_phase output basename dflags next_phase maybe_location 34 | | is_last_phase, Persistent <- output = persistent_fn 35 | | is_last_phase, SpecificFile <- output = case outputFile dflags of 36 | Just f -> return f 37 | Nothing -> 38 | panic "SpecificFile: No filename" 39 | | keep_this_output = persistent_fn 40 | | otherwise = newTempName dflags suffix 41 | where 42 | hcsuf = hcSuf dflags 43 | odir = objectDir dflags 44 | osuf = objectSuf dflags 45 | keep_hc = gopt Opt_KeepHcFiles dflags 46 | keep_s = gopt Opt_KeepSFiles dflags 47 | keep_bc = gopt Opt_KeepLlvmFiles dflags 48 | 49 | myPhaseInputExt HCc = hcsuf 50 | myPhaseInputExt MergeStub = osuf 51 | myPhaseInputExt StopLn = osuf 52 | myPhaseInputExt other = phaseInputExt other 53 | 54 | is_last_phase = next_phase `eqPhase` stop_phase 55 | 56 | -- sometimes, we keep output from intermediate stages 57 | keep_this_output = 58 | case next_phase of 59 | As _ | keep_s -> True 60 | LlvmOpt | keep_bc -> True 61 | HCc | keep_hc -> True 62 | _other -> False 63 | 64 | suffix = myPhaseInputExt next_phase 65 | 66 | -- persistent object files get put in odir 67 | persistent_fn 68 | | StopLn <- next_phase = return odir_persistent 69 | | otherwise = return persistent 70 | 71 | persistent = basename <.> suffix 72 | 73 | odir_persistent 74 | | Just loc <- maybe_location = ml_obj_file loc 75 | | Just d <- odir = d persistent 76 | | otherwise = persistent 77 | 78 | -- Copypaste from Finder 79 | 80 | -- | Constructs the filename of a .o file for a given source file. 81 | -- Does /not/ check whether the .o file exists 82 | mkObjPath 83 | :: DynFlags 84 | -> FilePath -- the filename of the source file, minus the extension 85 | -> String -- the module name with dots replaced by slashes 86 | -> FilePath 87 | mkObjPath dflags basename mod_basename = obj_basename <.> osuf 88 | where 89 | odir = objectDir dflags 90 | osuf = objectSuf dflags 91 | 92 | obj_basename | Just dir <- odir = dir mod_basename 93 | | otherwise = basename 94 | 95 | 96 | -- | Constructs the filename of a .hi file for a given source file. 97 | -- Does /not/ check whether the .hi file exists 98 | mkHiPath 99 | :: DynFlags 100 | -> FilePath -- the filename of the source file, minus the extension 101 | -> String -- the module name with dots replaced by slashes 102 | -> FilePath 103 | mkHiPath dflags basename mod_basename = hi_basename <.> hisuf 104 | where 105 | hidir = hiDir dflags 106 | hisuf = hiSuf dflags 107 | 108 | hi_basename | Just dir <- hidir = dir mod_basename 109 | | otherwise = basename 110 | 111 | -- Copypasted from GhcMake 112 | home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] 113 | home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, 114 | isLocal mb_pkg ] 115 | where isLocal Nothing = True 116 | isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special 117 | isLocal _ = False 118 | 119 | 120 | ms_home_srcimps :: ModSummary -> [Located ModuleName] 121 | ms_home_srcimps = home_imps . ms_srcimps 122 | 123 | ms_home_imps :: ModSummary -> [Located ModuleName] 124 | ms_home_imps = home_imps . ms_imps 125 | 126 | -- from MkIface 127 | putNameLiterally :: B.BinHandle -> Name -> IO () 128 | putNameLiterally bh name = 129 | do 130 | B.put_ bh $! nameModule name 131 | B.put_ bh $! nameOccName name 132 | -------------------------------------------------------------------------------- /GhcAction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NondecreasingIndentation #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | {-| 5 | Module : GhcAction 6 | Description : Reimplemented GHC functionality in the Action monad 7 | Copyright : (c) Edward Z. Yang, 2015-2016 8 | License : BSD3 9 | Maintainer : ezyang@cs.stanford.edu 10 | Stability : experimental 11 | Portability : portable 12 | 13 | A lot of behavior (e.g., how an @.o@ file is to be made) depends 14 | on our ability to actually find the relevant Haskell source file. 15 | In GHC, the 'Finder' is responsible for implementing this logic 16 | in the 'IO' monad. 17 | 18 | However, finder actions are relevant for recompilation in the 19 | build system. Thus, we reimplement them here in the 'Action' 20 | monad so that we can track them, and trigger a rebuild when the 21 | result of a finder would have changed. 22 | 23 | Shake caches the results of these, so we have to use a simplified 24 | 'FindResult' type which is 'Maybe (ModLocation, Module)'. 25 | -} 26 | module GhcAction where 27 | 28 | import GhcPlugins hiding ( varName ) 29 | import PrelNames ( gHC_PRIM ) 30 | import Finder ( mkHomeModLocation ) 31 | import Packages ( lookupModuleWithSuggestions ) 32 | 33 | import GhcShakeInstances () 34 | import Compat 35 | 36 | import Development.Shake 37 | import Development.Shake.Classes 38 | 39 | import Prelude hiding (mod) 40 | import qualified Data.Map as Map 41 | import Data.Map (Map) 42 | import System.FilePath 43 | 44 | -- | Reimplementation of GHC's @findImportedModule@: given a module name 45 | -- and possibly a package qualifying string (as in an @import "pkg" 46 | -- ModName@ statement), find the 'ModLocation' and 'Module' that GHC 47 | -- would consider this import pointing to. 48 | findImportedModule :: ModuleName -> Maybe FastString 49 | -> Action (Maybe (ModLocation, Module)) 50 | findImportedModule mod_name mb_pkg = 51 | case mb_pkg of 52 | Nothing -> unqual_import 53 | Just pkg | pkg == fsLit "this" -> home_import -- "this" is special 54 | | otherwise -> pkg_import 55 | where 56 | home_import = findHomeModule mod_name 57 | 58 | pkg_import = findExposedPackageModule (mod_name, mb_pkg) 59 | 60 | unqual_import = findHomeModule mod_name 61 | `orIfNotFound` 62 | findExposedPackageModule (mod_name, Nothing) 63 | 64 | -- | Reimplementation of GHC's @findExactModule@: given a fully 65 | -- qualified 'Module', find the 'ModLocation' and 'Module' that GHC 66 | -- would consider this import pointing to. 67 | findExactModule :: DynFlags -> Module -> Action (Maybe (ModLocation, Module)) 68 | findExactModule dflags mod = 69 | if moduleUnitId mod == thisPackage dflags 70 | then findHomeModule (moduleName mod) 71 | else findPackageModule mod 72 | 73 | -- | THIS IS AN ORACLE. A simplification of GHC's 74 | -- @lookupModuleWithSuggestions@, which is oracle'ized so we don't have 75 | -- to have an in-depth understanding of how GHC's package database is 76 | -- setup. (Oracle overhead will scale linearly with the number of 77 | -- imports, but these queries should all be quick lookups into the 78 | -- package database state.) 79 | lookupModule :: (ModuleName, Maybe FastString) -> Action (Maybe Module) 80 | lookupModule = askOracle 81 | 82 | -- | The backing implementation of 'lookupModule', to be passed to 83 | -- 'addOracle'. 84 | lookupModule' :: DynFlags -> (ModuleName, Maybe FastString) -> Action (Maybe Module) 85 | lookupModule' dflags (mod_name, mb_pkg) = 86 | case lookupModuleWithSuggestions dflags mod_name mb_pkg of 87 | LookupFound m _ -> return (Just m) 88 | _ -> return Nothing 89 | 90 | -- | Reimplementation of GHC's @findExposedPackageModule@: given a 91 | -- user import which is known not to be a home module, find it from 92 | -- the package database. 93 | findExposedPackageModule :: (ModuleName, Maybe FastString) 94 | -> Action (Maybe (ModLocation, Module)) 95 | findExposedPackageModule (mod_name, mb_pkg) = do 96 | mb_m <- lookupModule (mod_name, mb_pkg) 97 | case mb_m of 98 | Nothing -> return Nothing 99 | Just m -> findPackageModule m 100 | 101 | -- | THIS IS A PERSISTENT CACHE. Reimplementation of GHC's 102 | -- @findPackageModule@: given a fully qualified 'Module', find the 103 | -- location of its interface files. (This also returns the 'Module' for 104 | -- consistency; it's expected to be equal to the input.) 105 | findPackageModule :: Module -> Action (Maybe (ModLocation, Module)) 106 | findPackageModule = askOracle 107 | 108 | -- | The backing implementation of 'findPackageModule', to be passed to 109 | -- 'addPersistentCache'. 110 | findPackageModule' :: DynFlags -> (Module -> Action (Maybe (ModLocation, Module))) 111 | findPackageModule' dflags mod = do 112 | let 113 | pkg_id = moduleUnitId mod 114 | -- 115 | case lookupPackage dflags pkg_id of 116 | Nothing -> return Nothing 117 | Just pkg_conf -> findPackageModule_ dflags mod pkg_conf 118 | 119 | -- | Reimplementation of GHC's @findPackageModule_@, a helper function 120 | -- which also has the 'PackageConfig' for the module. 121 | -- 122 | -- TODO: PackageConfig should be oracle'ized, so that if a packagedb 123 | -- entry changes we recompile correctly, or the package database 124 | -- treated more correctly. 125 | findPackageModule_ :: DynFlags -> Module -> PackageConfig -> Action (Maybe (ModLocation, Module)) 126 | findPackageModule_ dflags mod pkg_conf = 127 | 128 | -- special case for GHC.Prim; we won't find it in the filesystem. 129 | if mod == gHC_PRIM 130 | then return Nothing 131 | else 132 | 133 | let 134 | tag = buildTag dflags 135 | 136 | -- hi-suffix for packages depends on the build tag. 137 | package_hisuf | null tag = "hi" 138 | | otherwise = tag ++ "_hi" 139 | 140 | mk_hi_loc f s = mkHiOnlyModLocation dflags package_hisuf f s 141 | 142 | import_dirs = importDirs pkg_conf 143 | -- we never look for a .hi-boot file in an external package; 144 | -- .hi-boot files only make sense for the home package. 145 | in 146 | case import_dirs of 147 | [one] | MkDepend <- ghcMode dflags -> do 148 | -- there's only one place that this .hi file can be, so 149 | -- don't bother looking for it. 150 | let basename = moduleNameSlashes (moduleName mod) 151 | loc = mk_hi_loc one basename 152 | return (Just (loc, mod)) 153 | _otherwise -> 154 | searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] 155 | 156 | -- | THIS IS A PERSISTENT CACHE. A reimplementation of GHC's 157 | -- @findHomeModule@: given a 'ModuleName' find the location of the home 158 | -- module that implements it. 159 | findHomeModule :: ModuleName -> Action (Maybe (ModLocation, Module)) 160 | findHomeModule = askOracle 161 | 162 | -- | The backing implementation of 'findHomeModule', to be passed to 163 | -- 'addPersistentCache'. 164 | findHomeModule' :: DynFlags 165 | -> (ModuleName -> Action (Maybe (ModLocation, Module))) 166 | findHomeModule' dflags mod_name = 167 | let 168 | home_path = importPaths dflags 169 | mod = mkModule (thisPackage dflags) mod_name 170 | 171 | exts = 172 | [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") 173 | , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") 174 | , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") 175 | , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") 176 | ] 177 | 178 | in 179 | if mod == gHC_PRIM 180 | then return Nothing 181 | else 182 | do mb_file <- askModuleNameFile mod_name 183 | case mb_file of 184 | Just file -> do 185 | loc <- liftIO $ mkHomeModLocation dflags mod_name file 186 | return (Just (loc, mod)) 187 | _ -> searchPathExts home_path mod exts 188 | 189 | -- | Newtype for 'askFileModuleName' question type. 190 | newtype FileModuleName = FileModuleName FilePath 191 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 192 | 193 | -- | THIS IS AN ORACLE. Given a file, this says what the module name 194 | -- name of it is. It's an oracle because this mapping depends on what 195 | -- command line arguments are passed to GHC. 196 | askFileModuleName :: FilePath -> Action ModuleName 197 | askFileModuleName = askOracle . FileModuleName 198 | 199 | -- | The backing implementation of 'askFileModuleName', to be passed 200 | -- to 'addOracle'. 201 | askFileModuleName' :: Map FilePath ModuleName -> FileModuleName -> Action ModuleName 202 | askFileModuleName' file_to_mod_name (FileModuleName file) = 203 | case Map.lookup file file_to_mod_name of 204 | Nothing -> error "illegal file" 205 | Just mod_name -> return mod_name 206 | 207 | -- | Newtype for 'askModuleNameFile' question type. 208 | newtype ModuleNameFile = ModuleNameFile ModuleName 209 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 210 | 211 | -- | THIS IS AN ORACLE. Given a module name, is there a file which 212 | -- implements it which was EXPLICITLY requested in the command line. 213 | -- It's an oracle because this mapping depends on what command line 214 | -- arguments are passed to GHC. 215 | askModuleNameFile :: ModuleName -> Action (Maybe FilePath) 216 | askModuleNameFile = askOracle . ModuleNameFile 217 | 218 | -- | The backing implementation of 'askModuleNameFile', to be passed 219 | -- to 'addOracle' 220 | askModuleNameFile' :: ModuleNameEnv FilePath -> ModuleNameFile -> Action (Maybe FilePath) 221 | askModuleNameFile' mod_name_to_file (ModuleNameFile mod_name) = return (lookupUFM mod_name_to_file mod_name) 222 | 223 | type FileExt = String 224 | type BaseName = String 225 | 226 | -- | Pure reimplementation of GHC's @mkHomeModLocationSearched@. 227 | mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt 228 | -> FilePath -> BaseName -> ModLocation 229 | mkHomeModLocationSearched dflags mod suff path basename = 230 | mkHomeModLocation2 dflags mod (if path == "." then basename 231 | else path basename) suff 232 | 233 | -- | Pure reimplementation of GHC's @mkHomeModLocation2@. 234 | mkHomeModLocation2 :: DynFlags 235 | -> ModuleName 236 | -> FilePath -- Of source module, without suffix 237 | -> String -- Suffix 238 | -> ModLocation 239 | mkHomeModLocation2 dflags mod src_basename ext = 240 | let mod_basename = moduleNameSlashes mod 241 | 242 | obj_fn = mkObjPath dflags src_basename mod_basename 243 | hi_fn = mkHiPath dflags src_basename mod_basename 244 | 245 | in (ModLocation{ ml_hs_file = Just (src_basename <.> ext), 246 | ml_hi_file = hi_fn, 247 | ml_obj_file = obj_fn }) 248 | 249 | -- | Pure reimplementation of GHC's @mkHiOnlyModLocation@. 250 | mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String 251 | -> ModLocation 252 | mkHiOnlyModLocation dflags hisuf path basename 253 | = let full_basename = path basename 254 | obj_fn = mkObjPath dflags full_basename basename 255 | in ModLocation{ ml_hs_file = Nothing, 256 | ml_hi_file = full_basename <.> hisuf, 257 | -- Remove the .hi-boot suffix from 258 | -- hi_file, if it had one. We always 259 | -- want the name of the real .hi file 260 | -- in the ml_hi_file field. 261 | ml_obj_file = obj_fn 262 | } 263 | 264 | -- | Reimplementation of GHC's @searchPathExts@, but tracking where 265 | -- was probed. 266 | searchPathExts 267 | :: [FilePath] -- paths to search 268 | -> Module -- module name 269 | -> [ ( 270 | FileExt, -- suffix 271 | FilePath -> BaseName -> ModLocation -- action 272 | ) 273 | ] 274 | -> Action (Maybe (ModLocation, Module)) 275 | 276 | searchPathExts paths mod exts 277 | = do result <- search to_search 278 | return result 279 | 280 | where 281 | basename = moduleNameSlashes (moduleName mod) 282 | 283 | to_search :: [(FilePath, ModLocation)] 284 | to_search = [ (file, fn path basename) 285 | | path <- paths, 286 | (ext,fn) <- exts, 287 | let base | path == "." = basename 288 | | otherwise = path basename 289 | file = base <.> ext 290 | ] 291 | 292 | search [] = return Nothing 293 | 294 | search ((file, loc) : rest) = do 295 | b <- doesFileExist file 296 | if b 297 | then return (Just (loc, mod)) 298 | else search rest 299 | 300 | -- | Reimplementation of GHC's @orIfNotFound@, but on a simplified type. 301 | orIfNotFound :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) 302 | orIfNotFound this or_this = do 303 | res <- this 304 | case res of 305 | Nothing -> or_this 306 | _ -> return res 307 | -------------------------------------------------------------------------------- /GhcShake.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NondecreasingIndentation #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | module GhcShake where 5 | 6 | import GhcPlugins hiding ( varName, errorMsg, fatalErrorMsg ) 7 | import GHC ( Ghc, setSessionDynFlags, getSession, GhcMonad(..), guessTarget ) 8 | import DriverPipeline ( compileFile, preprocess, compileOne', exeFileName, linkBinary ) 9 | import DriverPhases ( Phase(..), isHaskellSigFilename ) 10 | import PipelineMonad ( PipelineOutput(..) ) 11 | import StringBuffer ( hGetStringBuffer ) 12 | import HeaderInfo ( getImports ) 13 | import Finder ( addHomeModuleToFinder, mkHomeModLocation ) 14 | import Platform ( platformBinariesAreStaticLibs ) 15 | import LoadIface ( loadSysInterface, loadUserInterface ) 16 | import TcRnMonad ( initIfaceCheck ) 17 | import FlagChecker ( fingerprintDynFlags ) 18 | import TcRnTypes ( mkModDeps ) 19 | 20 | import Fingerprint 21 | import ErrUtils 22 | import Maybes 23 | import Panic 24 | 25 | import GhcShakeInstances 26 | import GhcAction 27 | import Compat 28 | import PersistentCache 29 | import BuildModule 30 | 31 | import Development.Shake 32 | import Development.Shake.Classes 33 | 34 | import Prelude hiding (mod) 35 | import System.Posix.Signals 36 | import qualified Data.Map as Map 37 | import qualified Data.HashMap.Strict as HashMap 38 | import Data.Dynamic 39 | import Data.List 40 | import Data.Tuple 41 | import Control.Monad 42 | import Control.Exception 43 | import System.Environment 44 | import System.Directory (createDirectoryIfMissing) 45 | import System.FilePath 46 | import System.Exit 47 | import System.IO 48 | 49 | frontendPlugin :: FrontendPlugin 50 | frontendPlugin = defaultFrontendPlugin { 51 | frontend = doShake 52 | } 53 | 54 | 55 | -- TODO: stop pulling things in from the EPS; use HPT so that 56 | -- we can correctly knot tie. 57 | 58 | ----------------------------------------------------------------------- 59 | 60 | -- THE BUILD SYSTEM 61 | 62 | ----------------------------------------------------------------------- 63 | 64 | doShake :: [String] -> [(String, Maybe Phase)] -> Ghc () 65 | doShake args srcs = do 66 | -- Fix up DynFlags to correct form 67 | liftIO $ putStrLn "Starting GHC" 68 | dflags0 <- fmap normaliseDynFlags getDynFlags 69 | _ <- setSessionDynFlags 70 | -- HACK: ghc --make -fno-code is not supposed to generate any 71 | -- interface files, but this is hard to implement in Shake so I 72 | -- am forcing -fwrite-interface in such cases. 73 | . flip gopt_set Opt_WriteInterface 74 | $ oneShotMakeDynFlags dflags0 75 | 76 | -- Get the full DynFlags and HscEnv after fixing DynFlags 77 | dflags <- getDynFlags 78 | hsc_env <- getSession 79 | 80 | -- The passed in @srcs@ have three functions: 81 | -- 1. They constitute our top-level 'want's, saying what 82 | -- we are going to build, 83 | -- 2. They tell us where to find source files, which 84 | -- may be non-obvious (see 'explicitFileMapping'), 85 | -- 3. They tell us what to link in. 86 | let (hs_srcs, non_hs_srcs) = partition haskellish srcs 87 | targets <- mapM (uncurry guessTarget) hs_srcs 88 | 89 | -- Compute the 'ModuleName'/'FilePath' mapping based on file targets 90 | mod_name_files <- liftIO $ explicitFileMapping hsc_env targets 91 | -- TODO: error if there's a clobber 92 | let mod_name_to_file = listToUFM mod_name_files 93 | file_to_mod_name = Map.fromList (map swap mod_name_files) 94 | -- TODO this assumes that main module is always thisPackage, 95 | -- I'm not sure if this is true 96 | mb_mainFile = lookupUFM mod_name_to_file (moduleName (mainModIs dflags)) 97 | mb_output_file = fmap guessOutputFile mb_mainFile 98 | 99 | -- Also get the object file mapping based on non-Haskell targets 100 | non_hs_o_files <- liftIO $ getNonHsObjectFiles dflags non_hs_srcs 101 | 102 | -- Setup the correctly guessed outputFile for linking 103 | let linker_dflags = dflags { outputFile = 104 | case outputFile dflags0 of 105 | Nothing -> mb_output_file 106 | r -> r 107 | } 108 | 109 | -- TODO: get rid of me? 110 | -- copypasted from DriverPipeline.hs 111 | let staticLink = case ghcLink dflags of 112 | LinkStaticLib -> True 113 | _ -> platformBinariesAreStaticLibs (targetPlatform dflags) 114 | liftIO $ do 115 | 116 | -- Restore normal signal handlers, since we're not GHCi! 117 | -- If we don't do this, ^C will not kill us correctly. 118 | -- TODO: don't try to do this on Windows 119 | _ <- installHandler sigINT Default Nothing 120 | _ <- installHandler sigHUP Default Nothing 121 | _ <- installHandler sigTERM Default Nothing 122 | _ <- installHandler sigQUIT Default Nothing 123 | 124 | -- Unwrap Shake exceptions so GHC's error handler handles it 125 | -- properly 126 | handleGhcErrors $ do 127 | 128 | withArgs args $ do 129 | let opts = shakeOptions { 130 | -- If we set -outputdir, we should not be influenced by 131 | -- build products in the source directory; similarly, 132 | -- we should have a different Shake instance in this case. 133 | -- Why not objectDir? Well, you've gotta draw the line 134 | -- somewhere... 135 | shakeFiles = case hiDir dflags of 136 | Just hidir -> hidir ".shake" 137 | Nothing -> ".shake", 138 | shakeThreads = fromMaybe 0 (parMakeCount dflags), 139 | shakeVersion = "1", 140 | shakeVerbosity = case verbosity dflags of 141 | -- Erm, I think this is right 142 | 0 -> Quiet 143 | 1 -> Normal 144 | 2 -> Normal -- [sic] 145 | 3 -> Loud 146 | 4 -> Chatty 147 | _ -> Diagnostic, 148 | -- shakeLint = Just LintBasic, -- for dev 149 | shakeAssume = if gopt Opt_ForceRecomp dflags 150 | then Just AssumeDirty 151 | else Nothing, 152 | shakeExtra = HashMap.fromList [(typeRep (Proxy :: Proxy DynFlags), toDyn dflags)] 153 | } 154 | shakeArgs opts $ do 155 | 156 | -- Oracles 157 | askNonHsObjectFiles <- fmap ($ NonHsObjectFiles ()) . addOracle $ 158 | \(NonHsObjectFiles ()) -> return non_hs_o_files 159 | askNonHsObjectPhase <- fmap (. NonHsObjectPhase) . addOracle $ 160 | let input_map = Map.fromList (zip non_hs_o_files non_hs_srcs) 161 | in \(NonHsObjectPhase input_fn) -> 162 | case Map.lookup input_fn input_map of 163 | Nothing -> error "askNonHsObjectPhase" 164 | Just r -> return r 165 | -- Un-hyphenated identifiers are how to invoke 166 | _ <- addOracle (askFileModuleName' file_to_mod_name) 167 | _ <- addOracle (askModuleNameFile' mod_name_to_file) 168 | _ <- addOracle (lookupModule' dflags) 169 | -- Having these be oracles means that we can properly reflect 170 | -- changes to -package flags. 171 | _ <- addOracle (findHomeModule' dflags) 172 | _ <- addOracle (findPackageModule' dflags) 173 | askThisPackage <- fmap ($ ThisPackage ()) . addOracle $ 174 | \(ThisPackage ()) -> return (thisPackage dflags) 175 | -- This is cached because we want unchanging builds to apply to this 176 | _ <- addPersistentCache (askRecompKey' hsc_env) 177 | 178 | -- Non-hs files 179 | want non_hs_o_files 180 | forM_ non_hs_o_files $ 181 | \output_fn -> do 182 | output_fn %> \_ -> do 183 | (input_fn, mb_phase) <- askNonHsObjectPhase output_fn 184 | need [input_fn] 185 | output_fn2 <- liftIO $ 186 | compileFile hsc_env StopLn (input_fn, mb_phase) 187 | assert (output_fn == output_fn2) $ return () 188 | -- TODO: read out dependencies from C compiler 189 | 190 | -- TODO: depend on packagedbs and arguments 191 | 192 | -- Want to build every target a user specified on the command line. 193 | action $ forP targets $ \target -> case target of 194 | Target{ targetId = TargetModule mod_name } -> 195 | needHomeModule mod_name >> return () 196 | Target{ targetId = TargetFile file _ } -> 197 | needFileTarget dflags file >> return () 198 | 199 | -- Linking is computed separately 200 | let a_root_isMain = any is_main_target targets 201 | is_main_target Target{ targetId = TargetModule mod_name } 202 | = mkModule (thisPackage dflags) mod_name == mainModIs dflags 203 | is_main_target Target{ targetId = TargetFile file _ } 204 | = case Map.lookup file file_to_mod_name of 205 | Nothing -> error "is_main_target" 206 | Just mod_name -> mkModule (thisPackage dflags) mod_name == mainModIs dflags 207 | 208 | if (not (isNoLink (ghcLink dflags)) && (a_root_isMain || gopt Opt_NoHsMain dflags)) 209 | then want [ exeFileName staticLink linker_dflags ] 210 | -- Replicated logic in GhcMake 211 | else when (isJust (outputFile linker_dflags) && ghcLink dflags == LinkBinary) $ 212 | action . liftIO $ do 213 | errorMsg dflags $ text 214 | ("output was redirected with -o, " ++ 215 | "but no output will be generated\n" ++ 216 | "because there is no " ++ 217 | moduleNameString (moduleName (mainModIs dflags)) ++ " module.") 218 | -- ick 219 | exitWith (ExitFailure 1) 220 | 221 | -- How to link the top-level thing 222 | exeFileName staticLink linker_dflags %> \out -> do 223 | Just main_find <- needMainModule dflags 224 | 225 | -- Compute the transitive home modules 226 | main_iface <- liftIO . initIfaceCheck hsc_env 227 | $ loadSysInterface (text "linking main") (mainModIs dflags) 228 | let home_deps = map fst -- get the ModuleName 229 | . filter (not . snd) -- filter out boot 230 | . dep_mods 231 | . mi_deps $ main_iface 232 | home_finds <- mapM needHomeModule home_deps 233 | let obj_files = map (ml_obj_file . fst) $ catMaybes home_finds 234 | need =<< askNonHsObjectFiles 235 | 236 | -- duplicated from linkBinary' in DriverPipeline 237 | -- depend on libraries in the library paths for relink 238 | let pkg_deps = map fst . dep_pkgs . mi_deps $ main_iface 239 | -- For now, we only accurately handle HS packages 240 | pkgs <- liftIO $ getPreloadPackagesAnd dflags pkg_deps 241 | forM_ pkgs $ \pkg -> do 242 | let libs = packageHsLibs dflags pkg 243 | paths0 = libraryDirs pkg 244 | pattern n 245 | | staticLink = "lib" ++ n ++ ".a" 246 | | otherwise = "lib" ++ n ++ ".so" 247 | search [] = return () 248 | search (path:paths) = do 249 | forM_ libs $ \lib -> do 250 | b <- doesFileExist (path pattern lib) 251 | when b $ need [path pattern lib] 252 | search paths 253 | search paths0 254 | 255 | -- Reimplements link' in DriverPipeline 256 | let link = case ghcLink dflags of 257 | LinkBinary -> linkBinary 258 | _ -> error ("don't know how to link this way " ++ show (ghcLink dflags)) 259 | 260 | putNormal ("Linking " ++ out ++ " ...") 261 | quietly . traced "linking" $ 262 | link linker_dflags 263 | (ml_obj_file (fst main_find) : obj_files) pkg_deps 264 | return () 265 | 266 | -- ToDo: rules for %.hi and %.o. These can be a bit annoying to 267 | -- manage, because we have to reverse engineer the correct module 268 | -- name. 269 | 270 | buildModuleRule $ \bm@(BuildModule raw_file mod is_boot) -> do 271 | 272 | -- Make sure we rebuild if -this-unit-id changes 273 | _ <- askThisPackage 274 | 275 | -- This is annoying 276 | let file = if is_boot then addBootSuffix raw_file else raw_file 277 | need [file] 278 | 279 | -- TODO: make preprocessing a separate rule. But how to deal 280 | -- with dflags modification? Need to refactor so we get a list 281 | -- of flags to apply (that's easier to serialize) 282 | (dflags', hspp_fn) <- liftIO $ preprocess hsc_env (file, Nothing) 283 | buf <- liftIO $ hGetStringBuffer hspp_fn 284 | (srcimps, the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file 285 | 286 | let non_boot_location = buildModuleLocation dflags bm { bm_is_boot = False } 287 | location = buildModuleLocation dflags bm 288 | log_path = buildModuleLogPath dflags bm 289 | mod' <- liftIO $ addHomeModuleToFinder hsc_env mod_name non_boot_location 290 | assert (mod == mod') $ return () 291 | 292 | -- Generate dependencies on how module lookup works. If the 293 | -- lookup changes we have to rebuild! 294 | let findImportedModules = 295 | mapM (\(mb_pkg, L _ mn) -> findImportedModule mn mb_pkg) 296 | locs <- findImportedModules the_imps 297 | src_locs <- findImportedModules srcimps 298 | 299 | -- Force the direct dependencies to be compiled. These are 300 | -- order only because we have fine-grained tracking too. 301 | orderOnlyAction $ do 302 | void . parallel $ map (needFindResult False) locs 303 | ++ map (needFindResult True) src_locs 304 | 305 | -- Clear the log 306 | liftIO $ createDirectoryIfMissing True (takeDirectory log_path) 307 | log_handle <- liftIO $ openFile log_path WriteMode 308 | 309 | -- Construct the ModSummary 310 | src_timestamp <- liftIO $ getModificationUTCTime file 311 | let hsc_src = if isHaskellSigFilename file 312 | then HsigFile 313 | else if is_boot 314 | then HsBootFile 315 | else HsSrcFile 316 | 317 | mod_summary = ModSummary { 318 | ms_mod = mod, 319 | ms_hsc_src = hsc_src, 320 | ms_location = location, 321 | ms_hspp_file = hspp_fn, 322 | ms_hspp_opts = dflags' 323 | { log_action = \a b c d e -> 324 | shakeLogAction log_handle a b c d e >> 325 | defaultLogAction a b c d e 326 | }, 327 | ms_hspp_buf = Just buf, 328 | ms_srcimps = srcimps, 329 | ms_textual_imps = the_imps, 330 | -- This shouldn't actually be used for anything 331 | ms_hs_date = src_timestamp, 332 | ms_iface_date = Nothing, 333 | ms_obj_date = Nothing 334 | } 335 | 336 | -- Build the module 337 | putNormal ("GHC " ++ file) 338 | let msg _ _ _ _ = return () -- Be quiet!! 339 | hmi <- quietly . traced file 340 | $ compileOne' Nothing (Just msg) hsc_env mod_summary 341 | -- We don't know what number the module 342 | -- we're building is 343 | 0 0 Nothing Nothing 344 | -- We skip GHC's recompiler checker by 345 | -- passing SourceModified because we 346 | -- reimplemented it 347 | SourceModified 348 | 349 | liftIO $ hClose log_handle 350 | 351 | -- Track fine-grained dependencies 352 | needInterfaceUsages dflags (hm_iface hmi) 353 | 354 | -- We'd like to add the hmi to the EPS (so we don't attempt 355 | -- to slurp it in later), but this sometimes deadlocks. Doesn't 356 | -- seem to hurt too much if we don't (since the interface 357 | -- is only loaded once anyways). 358 | 359 | return () 360 | 361 | ----------------------------------------------------------------------- 362 | 363 | -- THE HELPERS 364 | 365 | ----------------------------------------------------------------------- 366 | 367 | -- | Question type for oracle 'askNonHsObjectFiles'. 368 | newtype NonHsObjectFiles = NonHsObjectFiles () 369 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 370 | 371 | -- | Question type for oracle 'askNonHsObjectPhase'. 372 | newtype NonHsObjectPhase = NonHsObjectPhase String 373 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 374 | 375 | -- | Question type for oracle 'askThisPackage'. 376 | newtype ThisPackage = ThisPackage () 377 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 378 | 379 | -- | Remove any "." directory components from paths in 'DynFlags', to 380 | -- help prevent Shake from getting confused (since it doesn't 381 | -- normalise.) 382 | -- TODO: I'm not sure if this helps 383 | normaliseDynFlags :: DynFlags -> DynFlags 384 | normaliseDynFlags dflags = 385 | dflags { 386 | hiDir = fmap normalise (hiDir dflags), 387 | objectDir = fmap normalise (objectDir dflags), 388 | stubDir = fmap normalise (stubDir dflags), 389 | outputFile = fmap normalise (outputFile dflags), 390 | includePaths = map normalise (includePaths dflags), 391 | importPaths = map normalise (importPaths dflags) 392 | } 393 | 394 | -- | @ghc --make@ puts modules in the HPT but this is annoying 395 | -- to do in Shake, where we don't know the transitive closure 396 | -- of home modules we depend on; demand loading is much 397 | -- more convenient. The only way to demand load home modules 398 | -- is to be in one-shot mode; this function switches us to 399 | -- 'OneShot' mode, but makes some adjustments to make it simulate 400 | -- @--make@ mode. 401 | oneShotMakeDynFlags :: DynFlags -> DynFlags 402 | oneShotMakeDynFlags dflags = 403 | dflags { ghcMode = OneShot 404 | -- As a consequence of being in OneShot mode, 405 | -- the Finder doesn't search the output hi directory 406 | -- for interface files. So this is a gentle hack 407 | -- to make it search those directories too. 408 | , importPaths = maybe [] (:[]) (hiDir dflags) 409 | ++ importPaths dflags 410 | -- Another consequence of OneShot mode is that it 411 | -- will take the setting of outputFile seriously; 412 | -- however, we only really want that when linking. 413 | -- So unset outputFile for now. 414 | , outputFile = Nothing 415 | } 416 | 417 | -- | This function computes an association list between module 418 | -- names and file paths based on any file targets that were passed 419 | -- to GHC explicitly. 420 | -- 421 | -- The reason we need to do this is that what file target we specify 422 | -- can influence what hi/o file generates a source file. For example, 423 | -- suppose we have two files: 424 | -- 425 | -- @ 426 | -- -- A1.hs 427 | -- module A where 428 | -- 429 | -- -- A2.hs 430 | -- module A where 431 | -- @ 432 | -- 433 | -- If we run @ghc --make A1.hs -outputdir out@, @A1.hs@ is used to buld 434 | -- @out/A.hi@. But if we say @ghc --make A2.hs -outputdir out@ instead, 435 | -- @A2.hs@ will be used instead! (GHC will in fact silently clobber 436 | -- files if you specify both at the same time, see 437 | -- https://ghc.haskell.org/trac/ghc/ticket/11201) 438 | -- 439 | -- What does this mean for Shake? First, if we are asked to build some 440 | -- 'ModuleName', to figure out what source file may have generated it, 441 | -- we have to look at the file targets (parsing them to get the 442 | -- module header) to see if any of them define the module in question. 443 | -- Second, we need to make sure that we recompile if the file arguments 444 | -- change in a way that causes the source file we should use to 445 | -- change (normal recompilation checking will NOT catch this!) 446 | -- 447 | -- At the moment, we eagerly parse each file target to pull out its 448 | -- module name, and return an association list to handle this. 449 | -- 450 | -- TODO: Recompilation checking here is broken. 451 | explicitFileMapping :: HscEnv -> [Target] -> IO [(ModuleName, FilePath)] 452 | explicitFileMapping hsc_env targets = do 453 | let get_file_target Target { targetId = TargetFile file _ } = Just file 454 | get_file_target _ = Nothing 455 | file_targets = mapMaybe get_file_target targets 456 | dflags = hsc_dflags hsc_env 457 | forM file_targets $ \file -> do 458 | -- ahh, it's too bad that we have to redo the preprocessor... 459 | (dflags', hspp_fn) <- preprocess hsc_env (file, Nothing) 460 | buf <- hGetStringBuffer hspp_fn 461 | -- TODO do less work parsing! 462 | (_, _, L _ mod_name) <- getImports dflags' buf hspp_fn file 463 | -- Make sure we can find it! 464 | -- Why do we need this? Try building Setup.hs 465 | location <- mkHomeModLocation dflags mod_name file 466 | _ <- addHomeModuleToFinder hsc_env mod_name location 467 | return (mod_name, file) 468 | 469 | 470 | -- | If you want to build a @.o@ file, it is ambiguous whether or not it 471 | -- is a Haskell or C file. For example: 472 | -- 473 | -- > ghc --make A.c A.hs 474 | -- 475 | -- will clobber A.o (GHC's build system does no sanity check here.) 476 | -- However, we observe that GHC will never go off and build a 477 | -- non-Haskell source manually; it has to be in non_hs_srcs. So 478 | -- for EACH non_hs_srcs, we add a rule for how to build its product, 479 | -- with higher priority than the default Haskell rule, and leave 480 | -- it at that. To do that, we have to precompute the output 481 | -- filenames of each non_hs_src file. 482 | getNonHsObjectFiles :: DynFlags -> [(FilePath, Maybe Phase)] 483 | -> IO [FilePath] 484 | getNonHsObjectFiles dflags non_hs_srcs = 485 | forM non_hs_srcs $ \(input_fn, _) -> do 486 | -- This code was based off of @compileFile hsc_env StopLn x@ 487 | let -- Technically -fno-code should cause a temporary file to 488 | -- be made, but making this deterministic is better 489 | output = Persistent 490 | (basename, _) = splitExtension input_fn 491 | stopPhase = StopLn 492 | getOutputFilename stopPhase output basename dflags stopPhase Nothing 493 | 494 | -- | When we raise a 'GhcException' or a 'SourceError', try to give 495 | -- @ghc --make@ compatible output (without the extra Shake wrapping.) 496 | -- This is way better for users, since Shake does not print line numbers 497 | -- for SourceErrors. 498 | handleGhcErrors :: IO a -> IO a 499 | handleGhcErrors m = 500 | handle (\(e :: ShakeException) -> 501 | -- TODO: there should be a better way of doing this 502 | case fromException (shakeExceptionInner e) of 503 | Just (e' :: GhcException) -> throwIO e' 504 | Nothing -> case fromException (shakeExceptionInner e) of 505 | Just (e' :: SourceError) -> throwIO e' 506 | Nothing -> throwIO e 507 | ) m 508 | 509 | -- | Depend on a fully qualified Haskell module. 510 | needModule :: DynFlags -> Module -> IsBoot 511 | -> Action (Maybe (ModLocation, Module)) 512 | needModule dflags mod is_boot = 513 | needFindResult is_boot =<< findExactModule dflags mod 514 | 515 | -- | Depend on a module in the home package. 516 | needHomeModule :: ModuleName 517 | -> Action (Maybe (ModLocation, Module)) 518 | needHomeModule mod_name = 519 | needFindResult False =<< findHomeModule mod_name 520 | 521 | -- | Depend on the build products of a file target. 522 | needFileTarget :: DynFlags -> FilePath 523 | -> Action (Maybe (ModLocation, Module)) 524 | needFileTarget dflags file = do 525 | mod_name <- askFileModuleName file 526 | let is_boot = "-boot" `isSuffixOf` file 527 | mod = mkModule (thisPackage dflags) mod_name 528 | bm = BuildModule file mod is_boot 529 | needBuildModule bm 530 | return (Just (buildModuleLocation dflags bm, mod)) 531 | 532 | -- | Depend on the module pointed by a user import. 533 | needImportedModule :: IsBoot -> (Maybe FastString, Located ModuleName) 534 | -> Action (Maybe (ModLocation, Module)) 535 | needImportedModule is_boot (mb_pkg, L _ mod_name) = do 536 | needFindResult is_boot =<< findImportedModule mod_name mb_pkg 537 | 538 | -- | Depend on the main module (whatever that is!) 539 | -- 540 | -- TODO: Oracle-ize. 541 | needMainModule :: DynFlags -> Action (Maybe (ModLocation, Module)) 542 | needMainModule dflags = 543 | needHomeModule (moduleName (mainModIs dflags)) 544 | 545 | -- | Helper function to depend on a find result. 546 | needFindResult :: IsBoot -> Maybe (ModLocation, Module) -> Action (Maybe (ModLocation, Module)) 547 | needFindResult is_boot r = do 548 | let maybeAddBootSuffix 549 | | is_boot = addBootSuffix 550 | | otherwise = id 551 | case r of 552 | Just (loc, mod) -> 553 | case ml_hs_file loc of 554 | Nothing -> 555 | need [ maybeAddBootSuffix (ml_hi_file loc) ] 556 | Just src_file -> do 557 | needBuildModule (BuildModule src_file mod is_boot) 558 | _ -> return () -- Let GHC error when we actually try to look it up 559 | return r 560 | 561 | -- | Depend on the 'RecompKey's as reported by a 'ModIface'. 562 | needInterfaceUsages :: DynFlags -> ModIface -> Action () 563 | needInterfaceUsages dflags iface = do 564 | let -- Need this to check if it's boot or not 565 | mod_deps = mkModDeps (dep_mods (mi_deps iface)) 566 | usageKey UsagePackageModule{ usg_mod = mod } 567 | = [ ModuleHash mod ] 568 | usageKey UsageHomeModule{ usg_mod_name = mod_name 569 | , usg_entities = entities } 570 | = ExportHash mod is_boot 571 | : [ DeclHash mod is_boot occ | (occ, _) <- entities ] 572 | where mod = mkModule (thisPackage dflags) mod_name 573 | is_boot = case lookupUFM mod_deps mod_name of 574 | Nothing -> error "bad deps" 575 | Just (_, r) -> r 576 | usageKey UsageFile{} 577 | = [] 578 | usageFile UsageFile{ usg_file_path = path } 579 | = [path] 580 | usageFile _ = [] 581 | 582 | -- We could parallelize this but it's kind of pointless 583 | _ <- askRecompKey (FlagHash (mi_module iface)) 584 | mapM_ askRecompKey (concatMap usageKey (mi_usages iface)) 585 | need (concatMap usageFile (mi_usages iface)) 586 | 587 | -- | To make Shake's dependency tracking as accurate as possible, we 588 | -- reimplement GHC's recompilation avoidance. The idea: 589 | -- 590 | -- - We express an "orderOnly" constraint on direct 591 | -- interface files to make sure that everything 592 | -- GHC expects to be built is built. 593 | -- 594 | -- - We run GHC. 595 | -- 596 | -- - We register TRUE dependencies against what GHC 597 | -- recorded it used during compilation (the usage 598 | -- hashes.) 599 | -- 600 | -- Shake will only rebuild when these hashes change. 601 | -- 602 | -- We need a key for every hash we may want to depend upon, so that 603 | -- Shake can implement fine-grained dependency tracking; that's 604 | -- what 'RecompKey' is for. 605 | askRecompKey :: RecompKey -> Action Fingerprint 606 | askRecompKey = askPersistentCache 607 | 608 | -- | Backing implementation for 'askRecompKey'. 609 | askRecompKey' :: HscEnv -> RecompKey -> Action Fingerprint 610 | askRecompKey' hsc_env k = do 611 | let dflags = hsc_dflags hsc_env 612 | get_iface mod is_boot = do 613 | _ <- needModule dflags mod is_boot 614 | liftIO . initIfaceCheck hsc_env 615 | -- not really a user interface load, but it's the 616 | -- easiest way to specify boot-edness 617 | $ loadUserInterface is_boot (text "export hash") mod 618 | case k of 619 | FlagHash mod -> 620 | liftIO $ fingerprintDynFlags dflags mod putNameLiterally 621 | ExportHash mod is_boot -> 622 | fmap mi_exp_hash $ get_iface mod is_boot 623 | ModuleHash mod -> 624 | fmap mi_mod_hash $ get_iface mod False 625 | DeclHash mod is_boot occ -> do 626 | iface <- get_iface mod is_boot 627 | return $ case mi_hash_fn iface occ of 628 | Nothing -> error "could not find fingerprint" 629 | Just (_, fp) -> fp 630 | 631 | -- | If there is no -o option, guess the name of target executable 632 | -- by using top-level source file name as a base. 633 | -- 634 | -- Pure reimplementation of function in 'GhcMake'. 635 | guessOutputFile :: FilePath -> FilePath 636 | guessOutputFile mainModuleSrcPath = 637 | let name = dropExtension mainModuleSrcPath 638 | in if name == mainModuleSrcPath 639 | then throwGhcException . UsageError $ 640 | "default output name would overwrite the input file; " ++ 641 | "must specify -o explicitly" 642 | else name 643 | 644 | -- | Logs actions to a custom handle. (Mostly) copy-pasted from DynFlags 645 | shakeLogAction :: Handle -> LogAction 646 | shakeLogAction h dflags _reason severity srcSpan style msg 647 | = case severity of 648 | SevOutput -> printSDoc msg style 649 | SevDump -> printSDoc (msg $$ blankLine) style 650 | SevInteractive -> putStrSDoc msg style 651 | SevInfo -> printErrs msg style 652 | SevFatal -> printErrs msg style 653 | _ -> do hPutChar h '\n' 654 | printErrs message style 655 | -- careful (#2302): printErrs prints in UTF-8, 656 | -- whereas converting to string first and using 657 | -- hPutStr would just emit the low 8 bits of 658 | -- each unicode char. 659 | where printSDoc = defaultLogActionHPrintDoc dflags h 660 | printErrs = defaultLogActionHPrintDoc dflags h 661 | putStrSDoc = defaultLogActionHPutStrDoc dflags h 662 | -- TODO: print the warning flag if we can 663 | message = mkLocMessageAnn Nothing severity srcSpan msg 664 | -------------------------------------------------------------------------------- /GhcShakeInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | module GhcShakeInstances where 7 | 8 | -- stuff in this module is slow to compile, so split it out 9 | 10 | import GhcPlugins hiding (varName) 11 | import Fingerprint 12 | import Unique 13 | import OccName 14 | import DriverPhases 15 | 16 | import GHC.Generics (Generic) 17 | 18 | import Development.Shake.Classes 19 | import Data.Binary (getWord8, putWord8) 20 | 21 | -- A really useful typedef 22 | type IsBoot = Bool 23 | 24 | -- UnitId 25 | instance Show UnitId where 26 | show = unitIdString 27 | instance Binary UnitId where 28 | put = put . unitIdFS 29 | get = fmap fsToUnitId get 30 | instance NFData UnitId where 31 | rnf s = s `seq` () 32 | instance Hashable UnitId where 33 | hashWithSalt s a = getKey (getUnique a) + s 34 | 35 | -- ModuleName 36 | instance Show ModuleName where 37 | show = moduleNameString 38 | instance Binary ModuleName where 39 | put = put . moduleNameFS 40 | get = fmap mkModuleNameFS get 41 | instance Hashable ModuleName where 42 | hashWithSalt s a = getKey (getUnique a) + s 43 | instance NFData ModuleName where 44 | rnf s = s `seq` () 45 | 46 | -- Module 47 | instance Show Module where 48 | show m = show (moduleUnitId m) ++ ":" 49 | ++ show (moduleName m) 50 | instance NFData Module where 51 | rnf a = a `seq` () 52 | instance Binary Module where 53 | put m = do 54 | put (moduleUnitId m) 55 | put (moduleName m) 56 | get = do 57 | uid <- get 58 | mod_name <- get 59 | return (mkModule uid mod_name) 60 | instance Hashable Module where 61 | hashWithSalt s a = getKey (getUnique a) + s 62 | 63 | -- OccName 64 | instance Show OccName where 65 | show occ = occNameString occ ++ "{" ++ show (occNameSpace occ) ++ "}" 66 | instance NFData OccName where 67 | rnf a = a `seq` () 68 | instance Binary OccName where 69 | put occ = do 70 | putWord8 $ case occNameSpace occ of 71 | n | n == tcName -> 0 72 | | n == dataName -> 1 73 | | n == tvName -> 2 74 | | n == varName -> 3 75 | | otherwise -> error "what is this! 2" 76 | put (occNameFS occ) 77 | get = do 78 | tag <- getWord8 79 | fs <- get 80 | let ns = case tag of 81 | 0 -> tcName 82 | 1 -> dataName 83 | 2 -> tvName 84 | 3 -> varName 85 | _ -> error "what is this! 3" 86 | return (mkOccNameFS ns fs) 87 | instance Hashable OccName where 88 | hashWithSalt s a = getKey (getUnique a) + s 89 | 90 | -- NameSpace 91 | instance Show NameSpace where 92 | show n | n == tcName = "tc" 93 | | n == dataName = "d" 94 | | n == tvName = "tv" 95 | | n == varName = "v" 96 | | otherwise = error "what is this!" 97 | 98 | -- FastString 99 | instance Binary FastString where 100 | put = put . fastStringToByteString 101 | get = fmap mkFastStringByteString get 102 | instance NFData FastString where 103 | rnf s = s `seq` () 104 | instance Hashable FastString where 105 | hashWithSalt s fs = getKey (getUnique fs) + s 106 | 107 | -- Fingerprint 108 | instance Hashable Fingerprint where 109 | hashWithSalt s (Fingerprint w1 w2) = hashWithSalt s (w1, w2) 110 | 111 | -- HscSource 112 | deriving instance Generic HscSource 113 | deriving instance Typeable HscSource 114 | instance NFData HscSource 115 | instance Binary HscSource 116 | instance Hashable HscSource 117 | 118 | -- Phase 119 | deriving instance Generic Phase 120 | deriving instance Typeable Phase 121 | instance NFData Phase 122 | instance Binary Phase 123 | instance Hashable Phase 124 | 125 | -- | A 'RecompKey' is a key for a hash, for which recompilation can 126 | -- be predicated on. Each hash represents some aspect of a module 127 | -- which you could depend on. 128 | data RecompKey 129 | -- | The flags which were passed to compile a module. 130 | = FlagHash Module 131 | -- | The export list of a (boot) module 132 | | ExportHash Module IsBoot 133 | -- | The entire interface of the module 134 | | ModuleHash Module -- external package deps CANNOT be on boot 135 | -- | The declaration hash of a specific named entity 136 | | DeclHash Module IsBoot OccName 137 | deriving (Show, Typeable, Eq, Generic) 138 | 139 | instance Hashable RecompKey 140 | instance Binary RecompKey 141 | instance NFData RecompKey 142 | 143 | -- ModLocation 144 | deriving instance Generic ModLocation 145 | deriving instance Eq ModLocation 146 | instance Hashable ModLocation 147 | instance Binary ModLocation 148 | instance NFData ModLocation 149 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Edward Z. Yang 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Edward Z. Yang nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /PersistentCache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables, ConstraintKinds #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module PersistentCache( 5 | addPersistentCache, askPersistentCache 6 | ) where 7 | 8 | import Development.Shake 9 | import Development.Shake.Rule 10 | import Development.Shake.Classes 11 | import Control.Applicative 12 | import Prelude 13 | 14 | 15 | newtype CacheQ question = CacheQ question 16 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 17 | newtype CacheA answer = CacheA answer 18 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData) 19 | 20 | instance (ShakeValue q, ShakeValue a) => Rule (CacheQ q) (CacheA a) where 21 | storedValueE _ _ = return NeverRecomp 22 | 23 | 24 | -- | A persistent cache is a function from question type @q@, to an answer type @a@, 25 | -- which is cached across runs to Shake. Cached values are not 26 | -- recomputed unless any of their dependencies change. 27 | -- 28 | -- Persistent caches are used similarly to oracles, but unlike 29 | -- oracles, they are not rerun every invocation of Shake. Unlike 30 | -- 'newCache', these caches ARE saved to disk (and thus the value 31 | -- must be serializable), and you are not allowed to have two 32 | addPersistentCache :: (ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a) 33 | addPersistentCache act = do 34 | rule $ \(CacheQ q) -> Just $ CacheA <$> act q 35 | return askPersistentCache 36 | 37 | 38 | -- | Get information from a cached 'addPersistentCache'. The 39 | -- question/answer types must match those provided to 40 | -- 'addPersistentCache'. 41 | askPersistentCache :: (ShakeValue q, ShakeValue a) => q -> Action a 42 | askPersistentCache question = do CacheA answer <- apply1 $ CacheQ question; return answer 43 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ghc-shake 2 | 3 | This is a reimplementation of ghc --make using Shake. It's entirely one 4 | process, so unlike out-of-process Shake, you won't see any slowdown 5 | compared to --make if you compile with only one core. 6 | 7 | # What's the benefit? 8 | 9 | 1. You get faster rebuild checking, because Shake doesn't 10 | recompute the entire dependency graph (ghc --make must 11 | preprocess and parse all source code every time it loads.) 12 | 13 | 2. You can keep going even when one file fails to compile, 14 | making sure that anything can be built, is built. 15 | 16 | 3. You get all the nice Shake features, e.g. unchanging 17 | rebuilds and profiling. The profiling is really 18 | handy! 19 | 20 | # How do I use it? 21 | 22 | You'll need these two (somewhat hard to get) items: 23 | 24 | - GHC 8.0 25 | 26 | - A customized version of Shake: https://github.com/ezyang/shake 27 | 28 | - Appropriately patched copies of all of Shake's dependencies 29 | to work with GHC 8.0. If you wait, these will probably work 30 | out; but at the time of writing I needed to pass 31 | --allow-newer=base,transformers,process to cabal to get 32 | all of the dependencies to install. 33 | 34 | One way to to get everything installed (assuming GHC 8.0 is in your 35 | path) is to run: 36 | 37 | git clone https://github.com/ezyang/shake 38 | (cd shake && cabal install --allow-newer=base,transformers,process) 39 | git clone https://github.com/ezyang/ghc-shake 40 | (cd ghc-shake && cabal install --allow-newer=base,transformers,process) 41 | 42 | This will enable usage of `ghc --frontend GhcShake`. We have a sample 43 | script 'ghc-shake' in our source directory which you can pass to Cabal 44 | as a `--with-ghc` argument, which will override the meaning of `--make` 45 | (however, you'll need to edit the `-plugin-package-db` arguments to 46 | accurately reflect your installation. If you're not building ghc-shake 47 | in place, deleting them should be good enough.) 48 | 49 | # What doesn't work 50 | 51 | 1. Re-linking detection across packages. See 52 | https://ghc.haskell.org/trac/ghc/ticket/10161 53 | 54 | 2. Profiling. See 55 | https://ghc.haskell.org/trac/ghc/ticket/11293 56 | 57 | 3. Linking things that are not executables 58 | 59 | 4. Recompilation after package database changes. (We 60 | do correctly pick up changes to external interface 61 | files, however.) 62 | 63 | 5. ghc-shake is not really lib-ified properly (it 64 | should be namespaced and given explicit exports). 65 | I'll do this eventually. 66 | 67 | 6. hs-boot loops don't work; we don't properly 68 | invalidate the EPS when we successfully compile 69 | the replacement for an hs file. 70 | 71 | If you need something, shout and I'll try to implement it. 72 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ghc-shake: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ARGS=() 3 | for var in "$@"; do 4 | if [[ "$var" != '--make' || -n "$DISABLE_SHAKE" ]] 5 | then 6 | ARGS+=("$var") 7 | else 8 | ARGS+=("--frontend") 9 | ARGS+=("GhcShake") 10 | ARGS+=("-ffrontend-opt") 11 | ARGS+=("--digest-and") 12 | ARGS+=("-ffrontend-opt") 13 | ARGS+=("--profile") 14 | #ARGS+=("-ffrontend-opt") 15 | #ARGS+=("--debug") 16 | #ARGS+=("-ffrontend-opt") 17 | #ARGS+=("--keep-going") 18 | #ARGS+=("-ffrontend-opt") 19 | #ARGS+=("--progress=record") 20 | #ARGS+=("-ffrontend-opt") 21 | #ARGS+=("--no-time") 22 | ARGS+=("-ffrontend-opt") 23 | ARGS+=("--exception") 24 | ARGS+=("-package-db") 25 | ARGS+=("/home/ezyang/.cabal/store/ghc-8.0.1/package.db") 26 | ARGS+=("-package-db") 27 | ARGS+=("/srv/code/ghc-shake/dist-newstyle/packagedb/ghc-8.0.1") 28 | ARGS+=("-plugin-package") 29 | ARGS+=("ghc-shake") 30 | ARGS+=("-Wredundant-constraints") 31 | fi 32 | done 33 | exec "$(dirname $(realpath $0))/ghc" "${ARGS[@]}" $SHAKE_ARGS 34 | -------------------------------------------------------------------------------- /ghc-shake.cabal: -------------------------------------------------------------------------------- 1 | -- Initial ghc-shake.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: ghc-shake 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Edward Z. Yang 11 | maintainer: ezyang@cs.stanford.edu 12 | -- copyright: 13 | category: Development 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: GhcShake 20 | other-modules: GhcShakeInstances 21 | Compat 22 | GhcAction 23 | PersistentCache 24 | BuildModule 25 | -- other-extensions: 26 | build-depends: base, 27 | ghc == 8.0.*, 28 | shake, 29 | containers, 30 | binary, 31 | unix, 32 | unordered-containers, 33 | directory, 34 | filepath 35 | -- hs-source-dirs: 36 | default-language: Haskell2010 37 | ghc-options: -Wall 38 | -------------------------------------------------------------------------------- /scraps: -------------------------------------------------------------------------------- 1 | 2 | -- Add the HMI to the EPS 3 | -- PROBLEM: this occasionally deadlocks! Disaster. 4 | -- It's not a big deal if we don't, because we only pay the 5 | -- extra parsing cost once per module in HPT. 6 | {- 7 | let updateEpsIO_ f = liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\s -> (f s, ())) 8 | updateEpsIO_ $ \eps -> eps { 9 | -- TODO: refactor this into a "add ModDetails to EPS" 10 | -- function 11 | eps_PIT = extendModuleEnv (eps_PIT eps) mod (hm_iface hmi), 12 | eps_PTE = extendNameEnvList (eps_PTE eps) (map (\t -> (getName t, t)) (typeEnvElts (md_types (hm_details hmi)))), 13 | eps_rule_base = extendRuleBaseList (eps_rule_base eps) (md_rules (hm_details hmi)), 14 | eps_inst_env = extendInstEnvList (eps_inst_env eps) (md_insts (hm_details hmi)), 15 | eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) 16 | (md_fam_insts (hm_details hmi)), 17 | eps_vect_info = plusVectInfo (eps_vect_info eps) 18 | (md_vect_info (hm_details hmi)), 19 | eps_ann_env = extendAnnEnvList (eps_ann_env eps) 20 | (md_anns (hm_details hmi)), 21 | eps_mod_fam_inst_env 22 | = let 23 | fam_inst_env = 24 | extendFamInstEnvList emptyFamInstEnv 25 | (md_fam_insts (hm_details hmi)) 26 | in 27 | extendModuleEnv (eps_mod_fam_inst_env eps) 28 | mod 29 | fam_inst_env 30 | -- TODO: NO STATS 31 | } 32 | -} 33 | 34 | --------------------------------------------------------------------------------