diff options
58 files changed, 989 insertions, 144 deletions
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 0060d82f26..c696127bc0 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -7,6 +7,7 @@ module GHC.CoreToIface , toIfaceTvBndrs , toIfaceIdBndr , toIfaceBndr + , toIfaceTopBndr , toIfaceForAllBndr , toIfaceTyCoVarBinders , toIfaceTyVar @@ -35,6 +36,7 @@ module GHC.CoreToIface , toIfUnfolding , toIfaceTickish , toIfaceBind + , toIfaceTopBind , toIfaceAlt , toIfaceCon , toIfaceApp @@ -438,6 +440,15 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax +toIfaceTopBndr :: Id -> IfaceTopBndrInfo +toIfaceTopBndr id + = if isExternalName name + then IfGblTopBndr name + else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id)) + where + name = getName id + toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds @@ -570,10 +581,33 @@ toIfaceTickish (Breakpoint {}) = Nothing -- should not be serialised (#8333) --------------------- -toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] +toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo +toIfaceTopBind b = + case b of + NonRec b r -> uncurry IfaceNonRec (do_one (b, r)) + Rec prs -> IfaceRec (map do_one prs) + where + do_one (b, rhs) = + let top_bndr = toIfaceTopBndr b + rhs' = case top_bndr of + -- Use the existing unfolding for a global binder if we store that anyway. + -- See Note [Interface File with Core: Sharing RHSs] + IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs) + -- Local binders will have had unfoldings trimmed so have + -- to serialise the whole RHS. + IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs) + in (top_bndr, rhs') + + already_has_unfolding b = + -- The identifier has an unfolding, which we are going to serialise anyway + hasCoreUnfolding (realIdUnfolding b) + -- But not a stable unfolding, we want the optimised unfoldings. + && not (isStableUnfolding (realIdUnfolding b)) + --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) @@ -718,4 +752,31 @@ slower by 8% overall (on #9872a-d, and T1969: the reason is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop. +Note [Interface File with Core: Sharing RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to avoid duplicating definitions for bindings which already have unfoldings +we do some minor headstands to avoid serialising the RHS of a definition if it has +*any* unfolding. + +* Only global things have unfoldings, because local things have had their unfoldings stripped. +* For any global thing which has an unstable unfolding, we just use that. + +In order to implement this sharing: + +* When creating the interface, check the criteria above and don't serialise the RHS + if such a case. + See +* When reading an interface, look at the realIdUnfolding, and then the unfoldingTemplate. + See `tc_iface_binding` for where this happens. + +There are two main reasons why the mi_extra_decls field exists rather than shoe-horning +all the core bindings + +1. mi_extra_decls retains the recursive group structure of the original program which + is very convenient as otherwise we would have to do the analysis again when loading + the program. +2. There are additional local top-level bindings which don't make it into mi_decls. It's + best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash. + -} diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 81aa0c50fe..e961b3a242 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -340,7 +340,7 @@ buildUnit session cid insts lunit = do -- Compile relevant only hsc_env <- getSession let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . hm_linkable) + linkables = map (expectJust "bkp link" . homeModInfoObject) . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) $ home_mod_infos getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us) diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 9f3c14524f..83d87b6898 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -372,6 +372,7 @@ data GeneralFlag | Opt_KeepCAFs | Opt_KeepGoing | Opt_ByteCode + | Opt_ByteCodeAndObjectCode | Opt_LinkRts -- output style opts @@ -442,6 +443,8 @@ data GeneralFlag | Opt_KeepOFiles | Opt_BuildDynamicToo + | Opt_WriteIfSimplifedCore + | Opt_UseBytecodeRatherThanObjects -- safe haskell flags | Opt_DistrustAllPackages diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 93d5bbf3c4..175a78962e 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -46,11 +47,16 @@ module GHC.Driver.Main , Messager, batchMsg, batchMultiMsg , HscBackendAction (..), HscRecompStatus (..) , initModDetails + , initWholeCoreBindings , hscMaybeWriteIface , hscCompileCmmFile , hscGenHardCode , hscInteractive + , mkCgInteractiveGuts + , CgInteractiveGuts + , generateByteCode + , generateFreshByteCode -- * Running passes separately , hscRecompStatus @@ -146,7 +152,7 @@ import GHC.HsToCore import GHC.StgToByteCode ( byteCodeGen ) -import GHC.IfaceToCore ( typecheckIface ) +import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) import GHC.Iface.Load ( ifaceStats, writeIface ) import GHC.Iface.Make @@ -261,13 +267,20 @@ import Control.Monad import Data.IORef import System.FilePath as FilePath import System.Directory -import System.IO (fixIO) import qualified Data.Set as S import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.WholeCoreBindings +import GHC.Types.TypeEnv +import System.IO +import {-# SOURCE #-} GHC.Driver.Pipeline +import Data.Time + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import GHC.Iface.Env ( trace_if ) {- ********************************************************************** @@ -674,7 +687,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile - then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary + then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 @@ -804,7 +817,7 @@ hscRecompStatus :: Maybe Messager -> HscEnv -> ModSummary -> Maybe ModIface - -> Maybe Linkable + -> HomeModLinkable -> (Int,Int) -> IO HscRecompStatus hscRecompStatus @@ -833,26 +846,60 @@ hscRecompStatus if not (backendGeneratesCode (backend lcl_dflags)) then -- No need for a linkable, we're good to go do msg $ UpToDate - return $ HscUpToDate checked_iface Nothing + return $ HscUpToDate checked_iface emptyHomeModInfoLinkable else -- Do need linkable do - -- Check to see whether the expected build products already exist. - -- If they don't exists then we trigger recompilation. - recomp_linkable_result <- case () of - -- Interpreter can use either already loaded bytecode or loaded object code - _ | backendCanReuseLoadedCode (backend lcl_dflags) -> do - let res = checkByteCode old_linkable - case res of - UpToDateItem _ -> pure res - _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary - -- Need object files for making object files - | backendWritesFiles (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary - | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) + -- 1. Just check whether we have bytecode/object linkables and then + -- we will decide if we need them or not. + bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable) + obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary + trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable]) + + let just_bc = justBytecode <$> bc_linkable + just_o = justObjects <$> obj_linkable + _maybe_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplfied-core or you'll + -- end up using bytecode on recompilation + (_, UpToDateItem {} ) -> just_o + + definitely_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplfied-core or you'll + -- end up using bytecode on recompilation + (OutOfDateItem reason _, _ ) -> OutOfDateItem reason Nothing + +-- pprTraceM "recomp" (ppr just_bc <+> ppr just_o) + -- 2. Decide which of the products we will need + let recomp_linkable_result = case () of + _ | backendCanReuseLoadedCode (backend lcl_dflags) -> + case bc_linkable of + -- If bytecode is available for Interactive then don't load object code + UpToDateItem _ -> just_bc + _ -> case obj_linkable of + -- If o is availabe, then just use that + UpToDateItem _ -> just_o + _ -> outOfDateItemBecause MissingBytecode Nothing + -- Need object files for making object files + | backendWritesFiles (backend lcl_dflags) -> + if gopt Opt_ByteCodeAndObjectCode lcl_dflags + -- We say we are going to write both, so recompile unless we have both + then definitely_both_os + -- Only load the object file unless we are saying we need to produce both. + -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for. + else just_o + | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) case recomp_linkable_result of UpToDateItem linkable -> do msg $ UpToDate - return $ HscUpToDate checked_iface $ Just linkable + return $ HscUpToDate checked_iface $ linkable OutOfDateItem reason _ -> do msg $ NeedsRecompile reason return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface @@ -892,14 +939,24 @@ checkObjects dflags mb_old_linkable summary = do -- | Check to see if we can reuse the old linkable, by this point we will -- have just checked that the old interface matches up with the source hash, so -- no need to check that again here -checkByteCode :: Maybe Linkable -> MaybeValidated Linkable -checkByteCode mb_old_linkable = +checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable) +checkByteCode iface mod_sum mb_old_linkable = case mb_old_linkable of Just old_linkable | not (isObjectLinkable old_linkable) - -> UpToDateItem old_linkable - _ -> outOfDateItemBecause MissingBytecode Nothing + -> return $ (UpToDateItem old_linkable) + _ -> loadByteCode iface mod_sum +loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable) +loadByteCode iface mod_sum = do + let + this_mod = ms_mod mod_sum + if_date = fromJust $ ms_iface_date mod_sum + case mi_extra_decls iface of + Just extra_decls -> do + let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum) + return (UpToDateItem (LM if_date this_mod [CoreBindings fi])) + _ -> return $ outOfDateItemBecause MissingBytecode Nothing -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- @@ -907,11 +964,11 @@ checkByteCode mb_old_linkable = -- Knot tying! See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] -initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails -initModDetails hsc_env mod_summary iface = +initModDetails :: HscEnv -> ModIface -> IO ModDetails +initModDetails hsc_env iface = fixIO $ \details' -> do - let act hpt = addToHpt hpt (ms_mod_name mod_summary) - (HomeModInfo iface details' Nothing) + let act hpt = addToHpt hpt (moduleName $ mi_module iface) + (HomeModInfo iface details' emptyHomeModInfoLinkable) let !hsc_env' = hscUpdateHPT act hsc_env -- NB: This result is actually not that useful -- in one-shot mode, since we're not going to do @@ -919,6 +976,29 @@ initModDetails hsc_env mod_summary iface = -- in make mode, since this HMI will go into the HPT. genModDetails hsc_env' iface +-- Hydrate any WholeCoreBindings linkables into BCOs +initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable +initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls + where + go (CoreBindings fi) = do + let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface) + (HomeModInfo mod_iface details emptyHomeModInfoLinkable) + types_var <- newIORef (md_types details) + let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) + let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv } + core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi + -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do + -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone + -- reports a bug. + let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing [] + -- The bytecode generation itself is lazy because otherwise even when doing + -- recompilation checking the bytecode will be generated (which slows things down a lot) + -- the laziness is OK because generateByteCode just depends on things already loaded + -- in the interface file. + LoadedBCOs <$> (unsafeInterleaveIO $ do + trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod)) + generateByteCode hsc_env cgi_guts (wcb_mod_location fi)) + go ul = return ul {- Note [ModDetails and --make mode] @@ -1018,7 +1098,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details summary simplified_guts) + force (mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts) return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary, @@ -1026,11 +1106,29 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h hscs_old_iface_hash = mb_old_hash } - -- We are not generating code, so we can skip simplification + Just desugared_guts | gopt Opt_WriteIfSimplifedCore dflags -> do + -- If -fno-code is enabled (hence we fall through to this case) + -- Running the simplifier once is necessary before doing byte code generation + -- in order to inline data con wrappers but we honour whatever level of simplificication the + -- user requested. See #22008 for some discussion. + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + (cg_guts, _) <- + liftIO $ hscTidy hsc_env simplified_guts + + (iface, _details) <- liftIO $ + hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary + + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) + + return $ HscUpdate iface + + + -- We are not generating code or writing an interface with simplfied core so we can skip simplification -- and generate a simple interface. _ -> do (iface, _details) <- liftIO $ - hscSimpleIface hsc_env tc_result summary + hscSimpleIface hsc_env Nothing tc_result summary liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) @@ -1642,16 +1740,18 @@ hscSimplify' plugins ds_result = do -- | Generate a stripped down interface file, e.g. for boot files or when ghci -- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] hscSimpleIface :: HscEnv + -> Maybe CoreProgram -> TcGblEnv -> ModSummary -> IO (ModIface, ModDetails) -hscSimpleIface hsc_env tc_result summary - = runHsc hsc_env $ hscSimpleIface' tc_result summary +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary -hscSimpleIface' :: TcGblEnv +hscSimpleIface' :: Maybe CoreProgram + -> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails) -hscSimpleIface' tc_result summary = do +hscSimpleIface' mb_core_program tc_result summary = do hsc_env <- getHscEnv logger <- getLogger details <- liftIO $ mkBootModDetailsTc logger tc_result @@ -1659,7 +1759,7 @@ hscSimpleIface' tc_result summary = do new_iface <- {-# SCC "MkFinalIface" #-} liftIO $ - mkIfaceTc hsc_env safe_mode details summary tc_result + mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, details) @@ -1770,22 +1870,35 @@ hscGenHardCode hsc_env cgguts location output_filename = do return (output_filename, stub_c_exists, foreign_fps, Just cg_infos) +-- The part of CgGuts that we need for HscInteractive +data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module + , cgi_binds :: CoreProgram + , cgi_tycons :: [TyCon] + , cgi_foreign :: ForeignStubs + , cgi_modBreaks :: Maybe ModBreaks + , cgi_spt_entries :: [SptEntry] + } + +mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts +mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBreaks, cg_spt_entries} + = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_modBreaks cg_spt_entries + hscInteractive :: HscEnv - -> CgGuts + -> CgInteractiveGuts -> ModLocation -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) hscInteractive hsc_env cgguts location = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env - let CgGuts{ -- This is the last use of the ModGuts in a compilation. + let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks, - cg_spt_entries = spt_entries } = cgguts + cgi_module = this_mod, + cgi_binds = core_binds, + cgi_tycons = tycons, + cgi_foreign = foreign_stubs, + cgi_modBreaks = mod_breaks, + cgi_spt_entries = spt_entries } = cgguts data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1812,6 +1925,32 @@ hscInteractive hsc_env cgguts location = do <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs return (istub_c_exists, comp_bc, spt_entries) +generateByteCode :: HscEnv + -> CgInteractiveGuts + -> ModLocation + -> IO [Unlinked] +generateByteCode hsc_env cgguts mod_location = do + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileForeign hsc_env LangC stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + return (hs_unlinked ++ stub_o) + +generateFreshByteCode :: HscEnv + -> ModuleName + -> CgInteractiveGuts + -> ModLocation + -> IO Linkable +generateFreshByteCode hsc_env mod_name cgguts mod_location = do + ul <- generateByteCode hsc_env cgguts mod_location + unlinked_time <- getCurrentTime + let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul + return linkable ------------------------------ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 9089a2baa9..93681eba11 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -448,7 +448,7 @@ addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO () addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l) data CachedIface = CachedIface { cached_modiface :: !ModIface - , cached_linkable :: !(Maybe Linkable) } + , cached_linkable :: !HomeModLinkable } noIfaceCache :: Maybe ModIfaceCache noIfaceCache = Nothing @@ -833,7 +833,7 @@ pruneCache hpt summ linkable' | Just ms <- lookupUFM ms_map modl , mi_src_hash iface /= ms_hs_hash ms - = Nothing + = emptyHomeModInfoLinkable | otherwise = linkable @@ -1270,7 +1270,7 @@ upsweep_mod :: HscEnv -> IO HomeModInfo upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do hmi <- compileOne' mHscMessage hsc_env summary - mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable) + mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi) -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I @@ -1278,7 +1278,7 @@ upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do -- This function only does anything if the linkable produced is a BCO, which only happens with the -- bytecode backend, no need to guard against the backend type additionally. addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env) - (hm_linkable hmi) + (homeModInfoByteCode hmi) return hmi diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 1ab60387f1..04cd266f51 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- @@ -209,7 +210,7 @@ compileOne :: HscEnv -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one + -> HomeModLinkable -- ^ old linkable, if we have one -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne = compileOne' (Just batchMsg) @@ -220,7 +221,7 @@ compileOne' :: Maybe Messager -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one + -> HomeModLinkable -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne' mHscMessage @@ -243,8 +244,9 @@ compileOne' mHscMessage let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline -- See Note [ModDetails and --make mode] - details <- initModDetails plugin_hsc_env upd_summary iface - return $! HomeModInfo iface details linkable + details <- initModDetails plugin_hsc_env iface + linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) + return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' }) where lcl_dflags = ms_hspp_opts summary location = ms_location summary @@ -405,7 +407,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt $ home_mod_infos -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos + linkables = map (expectJust "link". homeModInfoObject) home_mod_infos debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) @@ -710,7 +712,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do $ phaseIfFlag hsc_env flag def action -- | The complete compilation pipeline, from start to finish -fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable) +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) fullPipeline pipe_env hsc_env pp_fn src_flavour = do (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn let hsc_env' = hscSetFlags dflags hsc_env @@ -719,7 +721,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) -- | Everything after preprocess -hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable) +hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do case hsc_recomp_status of HscUpToDate iface mb_linkable -> return (iface, mb_linkable) @@ -728,7 +730,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable) +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do @@ -739,8 +741,8 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = return res else case result of - HscUpdate iface -> return (iface, Nothing) - HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing + HscUpdate iface -> return (iface, emptyHomeModInfoLinkable) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure emptyHomeModInfoLinkable -- TODO: Why is there not a linkable? -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing @@ -749,7 +751,7 @@ hscGenBackendPipeline :: P m -> HscEnv -> ModSummary -> HscBackendAction - -> m (ModIface, Maybe Linkable) + -> m (ModIface, HomeModLinkable) hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) @@ -764,7 +766,8 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do unlinked_time <- liftIO (liftIO getCurrentTime) final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos) let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked] - return (Just linkable) + -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend. + return (mlinkable { homeMod_object = Just linkable }) return (miface, final_linkable) asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) @@ -860,7 +863,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase = as :: P m => Bool -> m (Maybe FilePath) as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn - objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk + objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk objFromLinkable _ = Nothing diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index b3737dc7e8..bddb1dfbde 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -26,7 +26,6 @@ import GHC.Unit.Types import GHC.Types.SourceFile import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface -import GHC.Linker.Types import GHC.Driver.Backend import GHC.Driver.Session import GHC.Driver.CmdLine @@ -57,7 +56,6 @@ import GHC.Unit.State import GHC.Unit.Home import GHC.Data.Maybe import GHC.Iface.Make -import Data.Time import GHC.Driver.Config.Parser import GHC.Parser.Header import GHC.Data.StringBuffer @@ -83,6 +81,7 @@ import GHC.Driver.Config.Finder import GHC.Rename.Names import Language.Haskell.Syntax.Module.Name +import GHC.Unit.Home.ModInfo newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -504,7 +503,7 @@ runHscBackendPhase :: PipeEnv -> HscSource -> ModLocation -> HscBackendAction - -> IO ([FilePath], ModIface, Maybe Linkable, FilePath) + -> IO ([FilePath], ModIface, HomeModLinkable, FilePath) runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env @@ -526,7 +525,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do HsBootFile -> touchObjectFile logger dflags o_file HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" - return ([], iface, Nothing, o_file) + return ([], iface, emptyHomeModInfoLinkable, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location, hscs_partial_iface = partial_iface, @@ -537,12 +536,21 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do else if backendWritesFiles (backend dflags) then do output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location) - (outputFilename, mStub, foreign_files, mb_cg_infos) <- + (outputFilename, mStub, foreign_files, cg_infos) <- + hscGenHardCode hsc_env cgguts mod_location output_fn - final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos + final_iface <- mkFullIface hsc_env partial_iface cg_infos -- See Note [Writing interface files] hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location + mlinkable <- + if backendGeneratesCode (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags + then do + bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location + return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } + + else return emptyHomeModInfoLinkable + stub_o <- mapM (compileStub hsc_env) mStub foreign_os <- @@ -553,7 +561,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do -- have some way to do before the object file is produced -- In future we can split up the driver logic more so that this function -- is in TPipeline and in this branch we can invoke the rest of the backend phase. - return (fos, final_iface, Nothing, outputFilename) + return (fos, final_iface, mlinkable, outputFilename) else -- In interpreted mode the regular codeGen backend is not run so we @@ -561,20 +569,8 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do do final_iface <- mkFullIface hsc_env partial_iface Nothing hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location - - (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time <- getCurrentTime - let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) - (hs_unlinked ++ stub_o) - return ([], final_iface, Just linkable, panic "interpreter") + bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location + return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter") runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath @@ -717,7 +713,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary - Nothing Nothing (1, 1) + Nothing emptyHomeModInfoLinkable (1, 1) return (plugin_hsc_env, mod_summary, status) diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs index 8868016f4d..c54bf2d838 100644 --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -17,10 +17,10 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation ) import GHC.Unit.Module.ModIface -import GHC.Linker.Types import GHC.Driver.Phases import Language.Haskell.Syntax.Module.Name ( ModuleName ) +import GHC.Unit.Home.ModInfo -- Typed Pipeline Phases -- MP: TODO: We need to refine the arguments to each of these phases so recompilation @@ -39,7 +39,7 @@ data TPhase res where -> Messages GhcMessage -> Maybe Fingerprint -> TPhase HscBackendAction - T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath) + T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, HomeModLinkable, FilePath) T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index fcb509f47f..cf6a5da5e3 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2902,10 +2902,11 @@ dynamic_flags_deps = [ , make_ord_flag defFlag "fbyte-code" (noArgM $ \dflags -> do setBackend interpreterBackend - pure $ gopt_set dflags Opt_ByteCode) - , make_ord_flag defFlag "fobject-code" $ NoArg $ do - dflags <- liftEwM getCmdLineState + pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode)) + , make_ord_flag defFlag "fobject-code" $ noArgM $ \dflags -> do setBackend $ platformDefaultBackend (targetPlatform dflags) + dflags' <- liftEwM getCmdLineState + pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode , make_dep_flag defFlag "fglasgow-exts" (NoArg enableGlasgowExts) "Use individual extensions instead" @@ -3480,6 +3481,7 @@ fFlagsDeps = [ flagSpec "strictness" Opt_Strictness, flagSpec "use-rpaths" Opt_RPath, flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-if-simplfied-core" Opt_WriteIfSimplifedCore, flagSpec "write-ide-info" Opt_WriteHie, flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, @@ -3500,7 +3502,9 @@ fFlagsDeps = [ flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, flagSpec "keep-cafs" Opt_KeepCAFs, flagSpec "link-rts" Opt_LinkRts, - flagSpec' "compact-unwind" Opt_CompactUnwind + flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, + flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, + flagSpec' "compact-unwind" Opt_CompactUnwind (\turn_on -> updM (\dflags -> do unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") @@ -3871,6 +3875,8 @@ impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ,(Opt_WriteIfSimplifedCore, turnOn, Opt_WriteInterface) + ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifedCore) ] ++ validHoleFitsImpliedGFlags -- General flags that are switched on/off when other general flags are switched diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 6e219cb257..aabca631b8 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1126,6 +1126,10 @@ pprModIface unit_state iface@ModIface{ mi_final_exts = exts } , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , case mi_extra_decls iface of + Nothing -> empty + Just eds -> text "extra decls:" + $$ nest 2 (vcat ([ppr bs | bs <- eds])) , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index fde785284a..8fa1fcb7e5 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -110,11 +110,12 @@ import Data.IORef -} mkPartialIface :: HscEnv + -> CoreProgram -> ModDetails -> ModSummary -> ModGuts -> PartialModIface -mkPartialIface hsc_env mod_details mod_summary +mkPartialIface hsc_env core_prog mod_details mod_summary ModGuts{ mg_module = this_mod , mg_hsc_src = hsc_src , mg_usages = usages @@ -128,7 +129,7 @@ mkPartialIface hsc_env mod_details mod_summary , mg_trust_pkg = self_trust , mg_docs = docs } - = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust + = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust safe_mode usages docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code @@ -185,9 +186,10 @@ mkIfaceTc :: HscEnv -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> ModSummary + -> Maybe CoreProgram -> TcGblEnv -- Usages, deprecations, etc -> IO ModIface -mkIfaceTc hsc_env safe_mode mod_details mod_summary +mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -228,7 +230,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary docs <- extractDocs (ms_hspp_opts mod_summary) tc_result let partial_iface = mkIface_ hsc_env - this_mod hsc_src + this_mod (fromMaybe [] mb_program) hsc_src used_th deps rdr_env fix_env warns hpc_info (imp_trust_own_pkg imports) safe_mode usages @@ -237,7 +239,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mkFullIface hsc_env partial_iface Nothing -mkIface_ :: HscEnv -> Module -> HscSource +mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo -> Bool @@ -248,7 +250,7 @@ mkIface_ :: HscEnv -> Module -> HscSource -> ModDetails -> PartialModIface mkIface_ hsc_env - this_mod hsc_src used_th deps rdr_env fix_env src_warns + this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages docs mod_summary ModDetails{ md_insts = insts, @@ -268,6 +270,9 @@ mkIface_ hsc_env semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) entities = typeEnvElts type_env show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) + + extra_decls = if gopt Opt_WriteIfSimplifedCore dflags then Just [ toIfaceTopBind b | b <- core_prog ] + else Nothing decls = [ tyThingToIfaceDecl show_linear_types entity | entity <- entities, let name = getName entity, @@ -319,6 +324,7 @@ mkIface_ hsc_env mi_globals = maybeGlobalRdrEnv rdr_env, mi_used_th = used_th, mi_decls = decls, + mi_extra_decls = extra_decls, mi_hpc = isHpcUsed hpc_info, mi_trust = trust_info, mi_trust_pkg = pkg_trust_req, diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index f4fac35375..ac4c2fe59e 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -70,7 +70,7 @@ import GHC.Unit.Module.Warnings import GHC.Unit.Module.Deps import Control.Monad -import Data.List (sortBy, sort) +import Data.List (sortBy, sort, sortOn) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64) @@ -137,6 +137,10 @@ data MaybeValidated a -- ^ The old item, if it exists deriving (Functor) +instance Outputable a => Outputable (MaybeValidated a) where + ppr (UpToDateItem a) = text "UpToDate" <+> ppr a + ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r + outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item @@ -1197,6 +1201,16 @@ addFingerprints hsc_env iface0 sorted_decls = Map.elems $ Map.fromList $ [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + -- This key is safe because mi_extra_decls contains tidied things. + getOcc (IfGblTopBndr b) = getOccName b + getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs + + binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () + binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) + + sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0 + -- the flag hash depends on: -- - (some of) dflags -- it returns two hashes, one that shouldn't change @@ -1254,7 +1268,7 @@ addFingerprints hsc_env iface0 , mi_fix_fn = fix_fn , mi_hash_fn = lookupOccEnv local_env } - final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } + final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts } -- return final_iface diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 7e7a1aa0c8..299dfe553b 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -5,14 +5,15 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Iface.Syntax ( module GHC.Iface.Type, IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), - IfaceBinding(..), IfaceConAlt(..), + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding, + IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..), IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), @@ -22,7 +23,7 @@ module GHC.Iface.Syntax ( IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), - IfaceLFInfo(..), + IfaceLFInfo(..), IfaceTopBndrInfo(..), -- * Binding names IfaceTopBndr, @@ -117,6 +118,7 @@ putIfaceTopBndr bh name = --pprTrace "putIfaceTopBndr" (ppr name) $ put_binding_name bh name + data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, @@ -548,7 +550,7 @@ data IfaceExpr | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr + | IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceLitRubbish IfaceType -- See GHC.Types.Literal @@ -571,15 +573,24 @@ data IfaceConAlt = IfaceDefault | IfaceDataAlt IfExtName | IfaceLitAlt Literal -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] +type IfaceBinding b = IfaceBindingX IfaceExpr b + +data IfaceBindingX r b + = IfaceNonRec b r + | IfaceRec [(b, r)] + deriving (Functor, Foldable, Traversable, Ord, Eq) -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo +data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails + | IfGblTopBndr IfaceTopBndr + +-- See Note [Interface File with Core: Sharing RHSs] +data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr + data IfaceJoinInfo = IfaceNotJoinPoint | IfaceJoinPoint JoinArity @@ -696,6 +707,21 @@ instance HasOccName IfaceDecl where instance Outputable IfaceDecl where ppr = pprIfaceDecl showToIface +instance (Outputable r, Outputable b) => Outputable (IfaceBindingX r b) where + ppr b = case b of + (IfaceNonRec b r) -> ppr_bind (b, r) + (IfaceRec pairs) -> sep [text "rec {", nest 2 (sep (map ppr_bind pairs)),text "}"] + where + ppr_bind (b, r) = ppr b <+> equals <+> ppr r + +instance Outputable IfaceTopBndrInfo where + ppr (IfLclTopBndr lcl_name _ _ _) = ppr lcl_name + ppr (IfGblTopBndr gbl) = ppr gbl + +instance Outputable IfaceMaybeRhs where + ppr IfUseUnfoldingRhs = text "<unfolding>" + ppr (IfRhs ie) = ppr ie + {- Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2452,7 +2478,7 @@ instance Binary IfaceConAlt where 1 -> liftM IfaceDataAlt $ get bh _ -> liftM IfaceLitAlt $ get bh -instance Binary IfaceBinding where +instance (Binary r, Binary b) => Binary (IfaceBindingX b r) where put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac get bh = do @@ -2473,6 +2499,38 @@ instance Binary IfaceLetBndr where d <- get bh return (IfLetBndr a b c d) +instance Binary IfaceTopBndrInfo where + put_ bh (IfLclTopBndr lcl ty info dets) = do + putByte bh 0 + put_ bh lcl + put_ bh ty + put_ bh info + put_ bh dets + put_ bh (IfGblTopBndr gbl) = do + putByte bh 1 + put_ bh gbl + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLclTopBndr <$> get bh <*> get bh <*> get bh <*> get bh + 1 -> IfGblTopBndr <$> get bh + _ -> pprPanic "IfaceTopBndrInfo" (intWithCommas tag) + +instance Binary IfaceMaybeRhs where + put_ bh IfUseUnfoldingRhs = putByte bh 0 + put_ bh (IfRhs e) = do + putByte bh 1 + put_ bh e + + get bh = do + b <- getByte bh + case b of + 0 -> return IfUseUnfoldingRhs + 1 -> IfRhs <$> get bh + _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) + + + instance Binary IfaceJoinInfo where put_ bh IfaceNotJoinPoint = putByte bh 0 put_ bh (IfaceJoinPoint ar) = do @@ -2630,11 +2688,19 @@ instance NFData IfaceExpr where instance NFData IfaceAlt where rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs -instance NFData IfaceBinding where +instance (NFData b, NFData a) => NFData (IfaceBindingX a b) where rnf = \case IfaceNonRec bndr e -> rnf bndr `seq` rnf e IfaceRec binds -> rnf binds +instance NFData IfaceTopBndrInfo where + rnf (IfGblTopBndr n) = n `seq` () + rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` () + +instance NFData IfaceMaybeRhs where + rnf IfUseUnfoldingRhs = () + rnf (IfRhs ce) = rnf ce `seq` () + instance NFData IfaceLetBndr where rnf (IfLetBndr nm ty id_info join_info) = rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 4ef629593c..ad975f1b0f 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -11,10 +11,12 @@ Type checking of type signatures in interface files {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE TupleSections #-} module GHC.IfaceToCore ( tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckWholeCoreBindings, typecheckIfacesForMerging, typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceDecls, @@ -22,7 +24,7 @@ module GHC.IfaceToCore ( tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, - tcIfaceOneShot + tcIfaceOneShot, tcTopIfaceBindings, ) where import GHC.Prelude @@ -118,6 +120,9 @@ import qualified GHC.Data.BooleanFormula as BF import Control.Monad import GHC.Parser.Annotation import GHC.Driver.Env.KnotVars +import GHC.Unit.Module.WholeCoreBindings +import Data.IORef +import Data.Foldable {- This module takes @@ -234,6 +239,12 @@ typecheckIface iface } } +typecheckWholeCoreBindings :: IORef TypeEnv -> WholeCoreBindings -> IfG [CoreBind] +typecheckWholeCoreBindings type_var (WholeCoreBindings prepd_binding this_mod _) = + initIfaceLcl this_mod (text "typecheckWholeCoreBindings") NotBoot $ do + tcTopIfaceBindings type_var prepd_binding + + {- ************************************************************************ * * @@ -892,6 +903,42 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) ; return (nm, idType id, b) } +tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + -> IfL [CoreBind] +tcTopIfaceBindings ty_var ver_decls + = do + int <- mapM tcTopBinders ver_decls + let all_ids :: [Id] = concatMap toList int + liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids)) + + extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int + +tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id) +tcTopBinders = traverse mk_top_id + +tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind +tc_iface_bindings (IfaceNonRec b rhs) = do + rhs' <- tc_iface_binding b rhs + return $ NonRec b rhs' +tc_iface_bindings (IfaceRec bs) = do + rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs + return (Rec rs) + +-- | See Note [Interface File with Core: Sharing RHSs] +tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr +tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfolding i) +tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs + +mk_top_id :: IfaceTopBndrInfo -> IfL Id +mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name +mk_top_id (IfLclTopBndr raw_name iface_type info details) = do + name <- newIfaceName (mkVarOccFS raw_name) + ty <- tcIfaceType iface_type + info' <- tcIdInfo False TopLevel name ty info + details' <- tcIdDetails ty details + let new_id = mkGlobalId details' name ty info' + return new_id + tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] @@ -1847,7 +1894,7 @@ tcIfaceGlobal name { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of - Failed err -> failIfM err + Failed err -> failIfM (ppr name <+> err) Succeeded thing -> return thing }}} diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 18ab333c08..3c9baf45cf 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -77,6 +77,7 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface +import GHC.Unit.Module.WholeCoreBindings import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages @@ -840,11 +841,17 @@ getLinkDeps hsc_env pls replace_osuf span mods while_linking_expr = text "while linking an interpreted expression" - -- This one is a build-system bug + + -- See Note [Using Byte Code rather than Object Code for Template Haskell] + homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable + homeModLinkable dflags hmi = + if gopt Opt_UseBytecodeRatherThanObjects dflags + then homeModInfoByteCode hmi <|> homeModInfoObject hmi + else homeModInfoObject hmi <|> homeModInfoByteCode hmi get_linkable osuf mod -- A home-package module | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env) - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -889,7 +896,34 @@ getLinkDeps hsc_env pls replace_osuf span mods adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) adjust_ul _ l@(BCOs {}) = return l + adjust_ul _ l@LoadedBCOs{} = return l + adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod) + +{- +Note [Using Byte Code rather than Object Code for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The `-fprefer-byte-code` flag allows a user to specify that they want to use +byte code (if availble) rather than object code for home module dependenices +when executing Template Haskell splices. + +Why might you want to use byte code rather than object code? +* Producing object code is much slower than producing byte code (for example if you're using -fno-code) +* Linking many large object files, which happens once per splice, is quite expensive. (#21700) + +So we allow the user to choose to use byte code rather than object files if they want to avoid these +two pitfalls. + +When using `-fprefer-byte-code` you have to arrange to have the byte code availble. +In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`. +See Note [Home module build products] for some more information about that. + +The only other place where the flag is consulted is when enabling code generation +with `-fno-code`, which does so to anticipate what decision we will make at the +splice point about what we would prefer. + +-} {- ********************************************************************** @@ -1133,7 +1167,7 @@ dynLinkBCOs bco_opts interp pls bcos = do unlinkeds = concatMap linkableUnlinked new_bcos cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds + cbcs = concatMap byteCodeOfObject unlinkeds ies = map bc_itbls cbcs diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs index 25df199b0f..605754b0ae 100644 --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -49,6 +49,7 @@ import Data.Maybe import GHC.Unit.Module.Env import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Unit.Module.WholeCoreBindings {- ********************************************************************** @@ -156,6 +157,10 @@ data Unlinked = DotO ObjFile -- ^ An object file (.o) | DotA FilePath -- ^ Static archive file (.a) | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend + -- See Note [Interface Files with Core Definitions] + | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid + -- being too strict. | BCOs CompiledByteCode [SptEntry] -- ^ A byte-code object, lives only in memory. Also -- carries some static pointer table entries which @@ -168,6 +173,8 @@ instance Outputable Unlinked where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + ppr (LoadedBCOs{}) = text "LoadedBCOs" + ppr (CoreBindings {}) = text "FI" -- | An entry to be inserted into a module's static pointer table. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". @@ -205,6 +212,8 @@ nameOfObject_maybe :: Unlinked -> Maybe FilePath nameOfObject_maybe (DotO fn) = Just fn nameOfObject_maybe (DotA fn) = Just fn nameOfObject_maybe (DotDLL fn) = Just fn +nameOfObject_maybe (CoreBindings {}) = Nothing +nameOfObject_maybe (LoadedBCOs{}) = Nothing nameOfObject_maybe (BCOs {}) = Nothing -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object @@ -212,8 +221,9 @@ nameOfObject :: Unlinked -> FilePath nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject :: Unlinked -> [CompiledByteCode] +byteCodeOfObject (BCOs bc _) = [bc] +byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) {- ********************************************************************** diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index c702fb5fea..abe98c2635 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -62,7 +62,6 @@ import GHCi.Message import GHCi.RemoteTypes import GHC.ByteCode.Types -import GHC.Linker.Types import GHC.Linker.Loader as Loader import GHC.Hs @@ -1242,17 +1241,18 @@ dynCompileExpr expr = do showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do - interpreted <- moduleIsBootOrNotObjectLinkable mod_summary let dflags = hsc_dflags hsc_env + let interpreted = + case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" - Just mod_info -> return $ case hm_linkable mod_info of - Nothing -> True - Just linkable -> not (isObjectLinkable linkable) + Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info ---------------------------------------------------------------------------- -- RTTI primitives diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index a61578278f..4f34cbf03b 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -752,7 +752,7 @@ fromEvalResult (EvalSuccess a) = return a getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- homeModInfoByteCode hmi, [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs index d66019a3ea..45129ddfb0 100644 --- a/compiler/GHC/Unit/Home/ModInfo.hs +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -1,6 +1,13 @@ -- | Info about modules in the "home" unit module GHC.Unit.Home.ModInfo ( HomeModInfo (..) + , HomeModLinkable(..) + , homeModInfoObject + , homeModInfoByteCode + , emptyHomeModInfoLinkable + , justBytecode + , justObjects + , bytecodeAndObjects , HomePackageTable , emptyHomePackageTable , lookupHpt @@ -27,7 +34,7 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module -import GHC.Linker.Types ( Linkable(..) ) +import GHC.Linker.Types ( Linkable(..), isObjectLinkable ) import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -35,6 +42,7 @@ import GHC.Types.Unique.DFM import GHC.Utils.Outputable import Data.List (sortOn) import Data.Ord +import GHC.Utils.Panic -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo @@ -48,25 +56,78 @@ data HomeModInfo = HomeModInfo -- This field is LAZY because a ModDetails is constructed by knot tying. - , hm_linkable :: !(Maybe Linkable) + , hm_linkable :: !HomeModLinkable -- ^ The actual artifact we would like to link to access things in - -- this module. + -- this module. See Note [Home module build products] -- - -- 'hm_linkable' might be Nothing: + -- 'hm_linkable' might be empty: -- -- 1. If this is an .hs-boot module -- -- 2. Temporarily during compilation if we pruned away -- the old linkable because it was out of date. -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields - -- in the 'HomePackageTable' will be @Just@. - -- -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the -- 'HomeModInfo' by building a new 'ModDetails' from the old -- 'ModIface' (only). } +homeModInfoByteCode :: HomeModInfo -> Maybe Linkable +homeModInfoByteCode = homeMod_bytecode . hm_linkable + +homeModInfoObject :: HomeModInfo -> Maybe Linkable +homeModInfoObject = homeMod_object . hm_linkable + +emptyHomeModInfoLinkable :: HomeModLinkable +emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing + +-- See Note [Home module build products] +data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) + , homeMod_object :: !(Maybe Linkable) } + +instance Outputable HomeModLinkable where + ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 + +justBytecode :: Linkable -> HomeModLinkable +justBytecode lm = + assertPpr (not (isObjectLinkable lm)) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } + +justObjects :: Linkable -> HomeModLinkable +justObjects lm = + assertPpr (isObjectLinkable lm) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_object = Just lm } + +bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable +bytecodeAndObjects bc o = + assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o) + (HomeModLinkable (Just bc) (Just o)) + + +{- +Note [Home module build products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When compiling a home module we can produce some combination of the following +build products. + +1. A byte code linkable, for use with the byte code interpreter. +2. An object file linkable, for linking a final executable or the byte code interpreter + +What we have produced is recorded in the `HomeModLinkable` type. In the case +that these linkables are produced they are stored in the relevant field so that +subsequent modules can retrieve and use them as necessary. + +* `-fbyte-code` will *only* produce a byte code linkable. This is the default in GHCi. +* `-fobject-code` will *only* produce an object file linkable. This is the default in -c and --make mode. +* `-fbyte-code-and-object-code` produces both a byte-code and object file linkable. So both fields are populated. + +Why would you want to produce both an object file and byte code linkable? If you +also want to use `-fprefer-byte-code` then you should probably also use this +flag to make sure that byte code is generated for your modules. + +-} + -- | Helps us find information about modules in the home package type HomePackageTable = DModuleNameEnv HomeModInfo -- Domain = modules in the home unit that have been fully compiled diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index f8b0bcc2c3..fcd6a63a28 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -282,12 +282,12 @@ showModMsg dflags recomp (ModuleNode _ mod_summary) = mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) dyn_file = op $ msDynObjFilePath mod_summary obj_file = op $ msObjFilePath mod_summary + files = [ obj_file ] + ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] message = case backendSpecialModuleSource (backend dflags) recomp of Just special -> text special - Nothing -> - if gopt Opt_BuildDynamicToo dflags - then text obj_file <> comma <+> text dyn_file - else text obj_file + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index 76cfff2b9f..1d5280f4fa 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -200,6 +200,11 @@ data ModIface_ (phase :: ModIfacePhase) -- Ditto data constructors, class operations, except that -- the hash of the parent class/tycon changes + mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo], + -- ^ Extra variable definitions which are **NOT** exposed but when + -- combined with mi_decls allows us to restart code generation. + -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] + mi_globals :: !(Maybe GlobalRdrEnv), -- ^ Binds all the things defined at the top level in -- the /original source/ code for this module. which @@ -349,6 +354,7 @@ instance Binary ModIface where mi_warns = warns, mi_anns = anns, mi_decls = decls, + mi_extra_decls = extra_decls, mi_insts = insts, mi_fam_insts = fam_insts, mi_rules = rules, @@ -392,6 +398,7 @@ instance Binary ModIface where lazyPut bh warns lazyPut bh anns put_ bh decls + put_ bh extra_decls put_ bh insts put_ bh fam_insts lazyPut bh rules @@ -423,6 +430,7 @@ instance Binary ModIface where warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh + extra_decls <- get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh @@ -446,6 +454,7 @@ instance Binary ModIface where mi_fixities = fixities, mi_warns = warns, mi_decls = decls, + mi_extra_decls = extra_decls, mi_globals = Nothing, mi_insts = insts, mi_fam_insts = fam_insts, @@ -494,6 +503,7 @@ emptyPartialModIface mod mi_fam_insts = [], mi_rules = [], mi_decls = [], + mi_extra_decls = Nothing, mi_globals = Nothing, mi_hpc = False, mi_trust = noIfaceTrustInfo, @@ -541,12 +551,13 @@ emptyIfaceHashCache _occ = Nothing -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` - f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` - rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 + f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` + rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` f21 `seq` f22 `seq` f23 `seq` rnf f24 `seq` () + instance NFData (ModIfaceBackend) where rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` diff --git a/compiler/GHC/Unit/Module/Status.hs b/compiler/GHC/Unit/Module/Status.hs index 6f926e3fb2..49851b74eb 100644 --- a/compiler/GHC/Unit/Module/Status.hs +++ b/compiler/GHC/Unit/Module/Status.hs @@ -10,13 +10,13 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface import GHC.Utils.Fingerprint -import GHC.Linker.Types import GHC.Utils.Outputable +import GHC.Unit.Home.ModInfo -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface (Maybe Linkable) + = HscUpToDate ModIface HomeModLinkable -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. diff --git a/compiler/GHC/Unit/Module/WholeCoreBindings.hs b/compiler/GHC/Unit/Module/WholeCoreBindings.hs new file mode 100644 index 0000000000..8e84abbf57 --- /dev/null +++ b/compiler/GHC/Unit/Module/WholeCoreBindings.hs @@ -0,0 +1,63 @@ +module GHC.Unit.Module.WholeCoreBindings where + +import GHC.Unit.Types (Module) +import GHC.Unit.Module.Location +import GHC.Iface.Syntax + +{- +Note [Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A interface file can optionally contain the definitions of all core bindings, this +is enabled by the flag `-fwrite-if-simplified-core`. +This provides everything needed in addition to the normal ModIface and ModDetails +to restart compilation after typechecking to generate bytecode. The `fi_bindings` field +is stored in the normal interface file and the other fields populated whilst loading +the interface file. + +The lifecycle of a WholeCoreBindings typically proceeds as follows: + +1. The ModIface which contains mi_extra_decls is loaded from disk. A linkable is + created (which is headed by the `CoreBindings` constructor). This is an unhydrated set of bindings which + is currently unsuitable for linking, but at the point it is loaded, the ModIface + hasn't been hydrated yet (See Note [Hydrating Modules]) either so the CoreBindings constructor allows the delaying of converting + the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also + allows us to convert the WholeCoreBindings into multiple different linkables if we so desired. + +2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together + all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to + create the linkable. The linkable created is a "LoadedBCOs" linkable, which + was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly. + Using the `BCOs` constructor directly here leads to the bytecode being forced + too eagerly. + +3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and + the linkable is used as before. + +The flag `-fwrite-if-simplfied-core` determines whether the extra information is written +to an interface file. The program which is written is the core bindings of the module +after whatever simplification the user requested has been performed. So the simplified core bindings +of the interface file agree with the optimisation level as reported by the interface +file. + +Note [Size of Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +How much overhead does `-fwrite-if-simplfied-core` add to a typical interface file? +As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with + +| Project | .hi | .hi (fat) | .o | +| --------| ---- | --------- | -- | +| ghc | 32M | 68M | 127M | +| Cabal | 3.2M | 9.8M | 14M | + +So the interface files gained in size but the end result was still smaller than +the object files. + +-} + +data WholeCoreBindings = WholeCoreBindings + { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + , wcb_module :: Module + , wcb_mod_location :: ModLocation + } diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 8e71fcaf31..7ae5a9b48a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -771,6 +771,7 @@ Library GHC.Unit.Module.ModDetails GHC.Unit.Module.ModGuts GHC.Unit.Module.ModIface + GHC.Unit.Module.WholeCoreBindings GHC.Unit.Module.ModSummary GHC.Unit.Module.Status GHC.Unit.Module.Warnings diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst index 052a24537f..be3ca70bf8 100644 --- a/docs/users_guide/phases.rst +++ b/docs/users_guide/phases.rst @@ -636,6 +636,19 @@ Options affecting code generation useful if you want to type check over multiple runs of GHC without compiling dependencies. +.. ghc-flag:: -fwrite-if-simplfied-core + :shortdesc: Write an interface file containing the simplified core of the module. + :type: dynamic + :category: codegen + + The interface file will contain all the bindings for a module. From + this interface file we can restart code generation to produce byte-code. + + The definition of bindings which are included in this + depend on the optimisation level. Any definitions which are already included in + an interface file (via an unfolding for an exported identifier) are reused. + + .. ghc-flag:: -fobject-code :shortdesc: Generate object code :type: dynamic @@ -643,7 +656,7 @@ Options affecting code generation Generate object code. This is the default outside of GHCi, and can be used with GHCi to cause object code to be generated in preference - to bytecode. + to byte-code. Therefore this flag disables :ghc-flag:`-fbyte-code-and-object-code`. .. ghc-flag:: -fbyte-code :shortdesc: Generate byte-code @@ -655,6 +668,19 @@ Options affecting code generation interpreter, not saved to disk. This option is only useful for reversing the effect of :ghc-flag:`-fobject-code`. +.. ghc-flag:: -fbyte-code-and-object-code + :shortdesc: Generate object code and byte-code + :type: dynamic + :category: codegen + + Generate object code and byte-code. This is useful with the flags + :ghc-flag:`-fprefer-byte-code` and :ghc-flag:`-fwrite-if-simplfied-core`. + + This flag implies :ghc-flag:`-fwrite-if-simplfied-core`. + + :ghc-flag:`-fbyte-code` and :ghc-flag:`-fobject-code` disable this flag as + they specify that GHC should *only* write object code or byte-code respectively. + .. ghc-flag:: -fPIC :shortdesc: Generate position-independent code (where available) :type: dynamic @@ -746,6 +772,24 @@ Options affecting code generation suppresses all non-global symbol table entries, resulting in smaller object file sizes at the expense of debuggability. + +.. ghc-flag:: -fprefer-byte-code + :shortdesc: Use byte-code if it is available to evaluate TH splices + :type: dynamic + :category: codegen + + If a home package module has byte-code available then use that instead of + and object file (if that's available) to evaluate and run TH splices. + + This is useful with flags such as :ghc-flag:`-fbyte-code-and-object-code`, which + tells the compiler to generate byte-code, and :ghc-flag:`-fwrite-if-simplfied-core` which + allows byte-code to be generated from an interface file. + + This flag also interacts with :ghc-flag:`-fno-code`, if this flag is enabled + then any modules which are required to be compiled for Template Haskell evaluation + will generate byte-code rather than object code. + + .. _options-linker: Options affecting linking diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs index e99ff405aa..51e3958ba2 100644 --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -22,6 +22,7 @@ import Prelude import System.Mem import System.Mem.Weak import GHC.Types.Unique.DFM +import Control.Exception -- Checking for space leaks in GHCi. See #15111, and the -- -fghci-leak-check flag. @@ -32,7 +33,7 @@ data LeakModIndicators = LeakModIndicators { leakMod :: Weak HomeModInfo , leakIface :: Weak ModIface , leakDetails :: Weak ModDetails - , leakLinkable :: Maybe (Weak Linkable) + , leakLinkable :: [Maybe (Weak Linkable)] } -- | Grab weak references to some of the data structures representing @@ -44,8 +45,12 @@ getLeakIndicators hsc_env = leakMod <- mkWeakPtr hmi Nothing leakIface <- mkWeakPtr hm_iface Nothing leakDetails <- mkWeakPtr hm_details Nothing - leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable + leakLinkable <- mkWeakLinkables hm_linkable return $ LeakModIndicators{..} + where + mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)] + mkWeakLinkables (HomeModLinkable mbc mo) = + mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo] -- | Look at the LeakIndicators collected by an earlier call to -- `getLeakIndicators`, and print messasges if any of them are still @@ -63,7 +68,7 @@ checkLeakIndicators dflags (LeakIndicators leakmods) = do Nothing -> return () Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface) deRefWeak leakDetails >>= report "ModDetails" - forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable" + forM_ leakLinkable $ \l -> forM_ l $ \l' -> deRefWeak l' >>= report "Linkable" where report :: String -> Maybe a -> IO () report _ Nothing = return () diff --git a/ghc/Main.hs b/ghc/Main.hs index 45dd5fede1..16075284c0 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -209,6 +209,11 @@ main' postLoadMode units dflags0 args flagWarnings = do where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges + -- Setting this by default has the nice effect that + -- -fno-code and --interactive falls back to interpreter rather than + -- object code but has little other effect unless you are also using + -- fat interface files. + `gopt_set` Opt_UseBytecodeRatherThanObjects logger1 <- getLogger let logger2 = setLogFlags logger1 (initLogFlags dflags2) diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 3a6bae10fb..51fb5ec96e 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -263,6 +263,7 @@ GHC.Unit.Module.ModIface GHC.Unit.Module.ModSummary GHC.Unit.Module.Status GHC.Unit.Module.Warnings +GHC.Unit.Module.WholeCoreBindings GHC.Unit.Parser GHC.Unit.Ppr GHC.Unit.State diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index df3f46f307..e9c2420d71 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -270,6 +270,7 @@ GHC.Unit.Module.ModIface GHC.Unit.Module.ModSummary GHC.Unit.Module.Status GHC.Unit.Module.Warnings +GHC.Unit.Module.WholeCoreBindings GHC.Unit.Parser GHC.Unit.Ppr GHC.Unit.State diff --git a/testsuite/tests/driver/fat-iface/Fat.hs b/testsuite/tests/driver/fat-iface/Fat.hs new file mode 100644 index 0000000000..6e6c795e99 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/Fat.hs @@ -0,0 +1,5 @@ +module Fat where + +f = 'f' +a = 'a' +t = 't' diff --git a/testsuite/tests/driver/fat-iface/FatMain.hs b/testsuite/tests/driver/fat-iface/FatMain.hs new file mode 100644 index 0000000000..ab0cf59588 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatMain.hs @@ -0,0 +1,5 @@ +module Main where + +import FatTH + +main = print top diff --git a/testsuite/tests/driver/fat-iface/FatQuote.hs b/testsuite/tests/driver/fat-iface/FatQuote.hs new file mode 100644 index 0000000000..e8a420fb7a --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatQuote.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module FatQuote where + +import Language.Haskell.TH + +a :: Q Exp +a = [| () |] + + diff --git a/testsuite/tests/driver/fat-iface/FatQuote1.hs b/testsuite/tests/driver/fat-iface/FatQuote1.hs new file mode 100644 index 0000000000..3cd07c0cfc --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatQuote1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module FatQuote1 where + +import FatQuote () + +import Language.Haskell.TH + +a :: Q Exp +a = [| () |] + + diff --git a/testsuite/tests/driver/fat-iface/FatQuote2.hs b/testsuite/tests/driver/fat-iface/FatQuote2.hs new file mode 100644 index 0000000000..53fd588868 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatQuote2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module FatQuote2 where + +import FatQuote () + +import Language.Haskell.TH + +a :: Q Exp +a = [| () |] + + diff --git a/testsuite/tests/driver/fat-iface/FatTH.hs b/testsuite/tests/driver/fat-iface/FatTH.hs new file mode 100644 index 0000000000..eebf917039 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatTH.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module FatTH where + +import FatQuote + +top = $(a) diff --git a/testsuite/tests/driver/fat-iface/FatTH1.hs b/testsuite/tests/driver/fat-iface/FatTH1.hs new file mode 100644 index 0000000000..e3aecb4ee7 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatTH1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fprefer-byte-code #-} +module FatTH1 where + +import FatQuote1 + +top = $(a) diff --git a/testsuite/tests/driver/fat-iface/FatTH2.hs b/testsuite/tests/driver/fat-iface/FatTH2.hs new file mode 100644 index 0000000000..6a9c3588d8 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatTH2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC #-} +module FatTH2 where + +import FatQuote2 + +top = $(a) diff --git a/testsuite/tests/driver/fat-iface/FatTHTop.hs b/testsuite/tests/driver/fat-iface/FatTHTop.hs new file mode 100644 index 0000000000..4315ead932 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/FatTHTop.hs @@ -0,0 +1,4 @@ +module FatTHTop where + +import FatTH1 +import FatTH2 diff --git a/testsuite/tests/driver/fat-iface/Makefile b/testsuite/tests/driver/fat-iface/Makefile new file mode 100644 index 0000000000..4c97828f15 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/Makefile @@ -0,0 +1,55 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +TEST_HC_OPTS_NO_RTSOPTS = $(filter-out -rtsopts,$(TEST_HC_OPTS)) + +clean: + rm -f *.hi *.hi-fat *.o + +fat001: clean + "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -fwrite-if-simplfied-core -dno-typeable-binds + test -f Fat.hi + "$(TEST_HC)" $(TEST_HC_OPTS) --show-iface Fat.hi | grep -A3 "extra decls" + +# If -fbyte-code-and-object-code is set then we should generate bytecode as the Linkable. +fat005: clean + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -ddump-bcos Fat.hs -fbyte-code-and-object-code + test -f Fat.o + +# Likewise, if -fbyte-code-and-object-code is off then don't produce bytecode +fat007: clean + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -ddump-bcos Fat.hs + + +fat006: clean + "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -dno-typeable-binds -fno-code -fwrite-if-simplfied-core + test -f Fat.hi + "$(TEST_HC)" $(TEST_HC_OPTS) --show-iface Fat.hi | grep -A3 "extra decls" + test ! -f Fat.o + +fat006a: clean + "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -dno-typeable-binds -fno-code -fwrite-if-simplfied-core -O2 + +fat008: clean + "$(TEST_HC)" $(TEST_HC_OPTS) FatTH.hs -fwrite-if-simplfied-core -fprefer-byte-code + echo >> "FatTH.hs" + # Observe that FatQuote.hs is not recompiled and the fat interface is used. + "$(TEST_HC)" $(TEST_HC_OPTS) FatTH.hs -fwrite-if-simplfied-core -fprefer-byte-code + + +# Same as fat008 but with ghci, broken due to recompilation checking wibbles + +fat009: clean + echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) FatTH.hs -fwrite-if-simplfied-core + echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) FatTH.hs -fwrite-if-simplfied-core + +fat010: clean + "$(TEST_HC)" $(TEST_HC_OPTS) THC.hs -fhide-source-paths -fwrite-if-simplfied-core -fprefer-byte-code + echo >> "THB.hs" + "$(TEST_HC)" $(TEST_HC_OPTS) THC.hs -fhide-source-paths -fwrite-if-simplfied-core -fprefer-byte-code + +fat014: clean + echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v0 -fno-code < fat014.script + + diff --git a/testsuite/tests/driver/fat-iface/THA.hs b/testsuite/tests/driver/fat-iface/THA.hs new file mode 100644 index 0000000000..93a86c8dee --- /dev/null +++ b/testsuite/tests/driver/fat-iface/THA.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import Control.Monad (when) + +th_a :: DecsQ +th_a = do + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + [d| a = () |] + +data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show +data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show +data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show + +class SingleMethodClass a where + classMethod :: a -> Bool + +instance SingleMethodClass Char where + classMethod = (== 'z') diff --git a/testsuite/tests/driver/fat-iface/THB.hs b/testsuite/tests/driver/fat-iface/THB.hs new file mode 100644 index 0000000000..13214ea674 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/THB.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA +import Control.Monad (when) + + + +$(do + -- Need to verify in both defining module and usage module" + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + th_a) diff --git a/testsuite/tests/driver/fat-iface/THC.hs b/testsuite/tests/driver/fat-iface/THC.hs new file mode 100644 index 0000000000..79a02ef601 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/testsuite/tests/driver/fat-iface/all.T b/testsuite/tests/driver/fat-iface/all.T new file mode 100644 index 0000000000..c4feaaa704 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/all.T @@ -0,0 +1,19 @@ +test('fat001', [extra_files(['Fat.hs'])], makefile_test, ['fat001']) +test('fat005', [extra_files(['Fat.hs']), filter_stdout_lines(r'= Proto-BCOs')], makefile_test, ['fat005']) +test('fat006', [extra_files(['Fat.hs'])], makefile_test, ['fat006']) +test('fat006a', [extra_files(['Fat.hs'])], makefile_test, ['fat006a']) +test('fat007', [extra_files(['Fat.hs'])], makefile_test, ['fat007']) +test('fat008', [unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs']), copy_files], makefile_test, ['fat008']) +test('fat009', [extra_files(['FatTH.hs', 'FatQuote.hs']), copy_files], makefile_test, ['fat009']) +test('fat010', [extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files], makefile_test, ['fat010']) +# Check linking works when using -fbyte-code-and-object-code +test('fat011', [extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code']) +# Check that we use interpreter rather than enable dynamic-too if needed for TH +test('fat012', [unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code']) +# Check that no objects are generated if using -fno-code and -fprefer-byte-code +test('fat013', [extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code']) +# When using interpreter should not produce objects +test('fat014', [extra_files(['FatTH.hs', 'FatQuote.hs'])], makefile_test, ['fat014']) +test('fat015', [unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) + + diff --git a/testsuite/tests/driver/fat-iface/fat001.stdout b/testsuite/tests/driver/fat-iface/fat001.stdout new file mode 100644 index 0000000000..6fa6a32f83 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat001.stdout @@ -0,0 +1,4 @@ +extra decls: + a = GHC.Types.C# 'a'# + f = GHC.Types.C# 'f'# + t = GHC.Types.C# 't'# diff --git a/testsuite/tests/driver/fat-iface/fat005.stdout b/testsuite/tests/driver/fat-iface/fat005.stdout new file mode 100644 index 0000000000..ffdb8d1db7 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat005.stdout @@ -0,0 +1,46 @@ + +==================== Proto-BCOs ==================== +ProtoBCO Fat.$trModule#0 []: + CCS_DONT_CARE GHC.Types.Module! [$trModule2_rvj $trModule4_rvl] + bitmap: 0 [] + PUSH_G $trModule4_rvl + PUSH_G $trModule2_rvj + PACK GHC.Types.Module 2 + ENTER + +ProtoBCO $trModule4_rvl#0 []: + CCS_DONT_CARE GHC.Types.TrNameS! [$trModule3_rvk] + bitmap: 0 [] + PUSH_UBX (1) 7045152## + PACK GHC.Types.TrNameS 1 + ENTER + +ProtoBCO $trModule2_rvj#0 []: + CCS_DONT_CARE GHC.Types.TrNameS! [$trModule1_rvi] + bitmap: 0 [] + PUSH_UBX (1) 140403554651664## + PACK GHC.Types.TrNameS 1 + ENTER + +ProtoBCO Fat.t#0 []: + CCS_DONT_CARE GHC.Types.C#! ['t'#] + bitmap: 0 [] + PUSH_UBX (1) 't'# + PACK GHC.Types.C# 1 + ENTER + +ProtoBCO Fat.a#0 []: + CCS_DONT_CARE GHC.Types.C#! ['a'#] + bitmap: 0 [] + PUSH_UBX (1) 'a'# + PACK GHC.Types.C# 1 + ENTER + +ProtoBCO Fat.f#0 []: + CCS_DONT_CARE GHC.Types.C#! ['f'#] + bitmap: 0 [] + PUSH_UBX (1) 'f'# + PACK GHC.Types.C# 1 + ENTER + + diff --git a/testsuite/tests/driver/fat-iface/fat006.stdout b/testsuite/tests/driver/fat-iface/fat006.stdout new file mode 100644 index 0000000000..6fa6a32f83 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat006.stdout @@ -0,0 +1,4 @@ +extra decls: + a = GHC.Types.C# 'a'# + f = GHC.Types.C# 'f'# + t = GHC.Types.C# 't'# diff --git a/testsuite/tests/driver/fat-iface/fat008.stdout b/testsuite/tests/driver/fat-iface/fat008.stdout new file mode 100644 index 0000000000..8841ce10b2 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat008.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling FatQuote ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o ) +[2 of 2] Compiling FatTH ( FatTH.hs, FatTH.o, FatTH.dyn_o ) +[2 of 2] Compiling FatTH ( FatTH.hs, FatTH.o, FatTH.dyn_o ) [Source file changed] diff --git a/testsuite/tests/driver/fat-iface/fat010.stdout b/testsuite/tests/driver/fat-iface/fat010.stdout new file mode 100644 index 0000000000..74dea74a77 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat010.stdout @@ -0,0 +1,4 @@ +[1 of 3] Compiling THA +[2 of 3] Compiling THB +[3 of 3] Compiling THC +[2 of 3] Compiling THB [Source file changed] diff --git a/testsuite/tests/driver/fat-iface/fat011.stderr b/testsuite/tests/driver/fat-iface/fat011.stderr new file mode 100644 index 0000000000..71fe78f06a --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat011.stderr @@ -0,0 +1,4 @@ +[1 of 4] Compiling FatQuote ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o, interpreted ) +[2 of 4] Compiling FatTH ( FatTH.hs, FatTH.o, FatTH.dyn_o, interpreted ) +[3 of 4] Compiling Main ( FatMain.hs, FatMain.o, interpreted ) +[4 of 4] Linking FatMain diff --git a/testsuite/tests/driver/fat-iface/fat012.stderr b/testsuite/tests/driver/fat-iface/fat012.stderr new file mode 100644 index 0000000000..95ac650ae4 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat012.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling FatQuote ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o ) +[2 of 2] Compiling FatTH ( FatTH.hs, FatTH.o, FatTH.dyn_o ) diff --git a/testsuite/tests/driver/fat-iface/fat013.stderr b/testsuite/tests/driver/fat-iface/fat013.stderr new file mode 100644 index 0000000000..bf181cfc4a --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat013.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling FatQuote ( FatQuote.hs, /run/user/1000/ghc1303986_0/ghc_2.o, /run/user/1000/ghc1303986_0/ghc_2.dyn_o ) +[2 of 2] Compiling FatTH ( FatTH.hs, /run/user/1000/ghc1303986_0/ghc_4.o, /run/user/1000/ghc1303986_0/ghc_4.dyn_o ) diff --git a/testsuite/tests/driver/fat-iface/fat014.script b/testsuite/tests/driver/fat-iface/fat014.script new file mode 100644 index 0000000000..63a8a0d97d --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat014.script @@ -0,0 +1,2 @@ +:set -v1 +:l FatTH.hs diff --git a/testsuite/tests/driver/fat-iface/fat014.stdout b/testsuite/tests/driver/fat-iface/fat014.stdout new file mode 100644 index 0000000000..52d0811a33 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat014.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling FatQuote ( FatQuote.hs, /run/user/1000/ghc1304860_0/ghc_2.o ) +[2 of 2] Compiling FatTH ( FatTH.hs, /run/user/1000/ghc1304860_0/ghc_4.o ) +Ok, two modules loaded. diff --git a/testsuite/tests/driver/fat-iface/fat015.stderr b/testsuite/tests/driver/fat-iface/fat015.stderr new file mode 100644 index 0000000000..ba51cd4ab0 --- /dev/null +++ b/testsuite/tests/driver/fat-iface/fat015.stderr @@ -0,0 +1,6 @@ +[1 of 6] Compiling FatQuote ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o ) +[2 of 6] Compiling FatQuote1 ( FatQuote1.hs, FatQuote1.o, FatQuote1.dyn_o ) +[3 of 6] Compiling FatQuote2 ( FatQuote2.hs, FatQuote2.o, FatQuote2.dyn_o ) +[4 of 6] Compiling FatTH1 ( FatTH1.hs, FatTH1.o, FatTH1.dyn_o ) +[5 of 6] Compiling FatTH2 ( FatTH2.hs, FatTH2.o, FatTH2.dyn_o ) +[6 of 6] Compiling FatTHTop ( FatTHTop.hs, nothing ) diff --git a/testsuite/tests/ghci/T16670/Makefile b/testsuite/tests/ghci/T16670/Makefile index 586f7e7fe7..ff5e8f1ac7 100644 --- a/testsuite/tests/ghci/T16670/Makefile +++ b/testsuite/tests/ghci/T16670/Makefile @@ -19,6 +19,6 @@ T16670_th: $(MAKE) -s --no-print-directory clean mkdir my-odir echo ":load T16670_th.hs" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \ - -v0 -fno-code -fwrite-interface -odir my-odir - find . -name T16670_th.o - test -f my-odir/T16670_th.o + -v0 -fno-code -fno-prefer-byte-code -fwrite-interface -odir my-odir + find . -name TH.o + test -f my-odir/TH.o diff --git a/testsuite/tests/ghci/T16670/T16670_th.stdout b/testsuite/tests/ghci/T16670/T16670_th.stdout index 708b93a384..bd3e413b8a 100644 --- a/testsuite/tests/ghci/T16670/T16670_th.stdout +++ b/testsuite/tests/ghci/T16670/T16670_th.stdout @@ -1,2 +1,2 @@ ~~~~~~~~ testing T16670_th -./my-odir/T16670_th.o +./my-odir/TH.o diff --git a/testsuite/tests/ghci/scripts/ghci024.stdout b/testsuite/tests/ghci/scripts/ghci024.stdout index 9b13afa9de..c7ddba4f62 100644 --- a/testsuite/tests/ghci/scripts/ghci024.stdout +++ b/testsuite/tests/ghci/scripts/ghci024.stdout @@ -13,6 +13,7 @@ other dynamic, non-language, flag settings: -fimplicit-import-qualified -fkeep-going -fshow-warning-groups + -fprefer-byte-code warning settings: -Wsemigroup -Wstar-is-type diff --git a/testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 b/testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 index bc008a3ddc..7dea29c218 100644 --- a/testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 +++ b/testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 @@ -12,6 +12,7 @@ other dynamic, non-language, flag settings: -fimplicit-import-qualified -fkeep-going -fshow-warning-groups + -fprefer-byte-code warning settings: -Wsemigroup -Wstar-is-type |