diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 16 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 17 | ||||
| -rw-r--r-- | compiler/main/Hooks.hs | 7 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 30 | ||||
| -rw-r--r-- | compiler/main/UpdateCafInfos.hs | 141 |
5 files changed, 174 insertions, 37 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 823d3d75ff..0781b1a6d8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -69,6 +69,7 @@ import Ar import Bag ( unitBag ) import FastString ( mkFastString ) import GHC.Iface.Utils ( mkFullIface ) +import UpdateCafInfos ( updateModDetailsCafInfos ) import Exception import System.Directory @@ -228,8 +229,8 @@ compileOne' m_tc_result mHscMessage hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface - liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location + final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location @@ -1188,15 +1189,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do PipeState{hsc_env=hsc_env'} <- getPipeState - (outputFilename, mStub, foreign_files) <- liftIO $ + (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_location output_fn - final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) - -- TODO(osa): ModIface and ModDetails need to be in sync, - -- but we only generate ModIface with the backend info. See - -- !2100 for more discussion on this. This will be fixed - -- with !1304 or !2100. - setIface final_iface mod_details + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos)) + let final_mod_details = updateModDetailsCafInfos caf_infos mod_details + setIface final_iface final_mod_details -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 5c5d01c546..be40ff9e2e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -427,6 +427,7 @@ data DumpFlag | Opt_D_dump_cmm_split | Opt_D_dump_cmm_info | Opt_D_dump_cmm_cps + | Opt_D_dump_srts -- end cmm subflags | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. | Opt_D_dump_asm @@ -3358,6 +3359,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_cmm_info) , make_ord_flag defGhcFlag "ddump-cmm-cps" (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-srts" + (setDumpFlag Opt_D_dump_srts) , make_ord_flag defGhcFlag "ddump-cfg-weights" (setDumpFlag Opt_D_dump_cfg_weights) , make_ord_flag defGhcFlag "ddump-core-stats" @@ -4791,20 +4794,6 @@ optLevelFlags -- see Note [Documenting optimisation flags] -- Static Argument Transformation needs investigation. See #9374 ] -{- Note [Eta-reduction in -O0] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#11562 showed an example which tripped an ASSERT in CoreToStg; a -function was marked as MayHaveCafRefs when in fact it obviously -didn't. Reason was: - * Eta reduction wasn't happening in the simplifier, but it was - happening in CorePrep, on - $fBla = MkDict (/\a. K a) - * Result: rhsIsStatic told GHC.Iface.Tidy that $fBla might have CAF refs - but the eta-reduced version (MkDict K) obviously doesn't -Simple solution: just let the simplifier do eta-reduction even in -O0. -After all, CorePrep does it unconditionally! Not a big deal, but -removes an assertion failure. -} - -- ----------------------------------------------------------------------------- -- Standard sets of warning options diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index 8caebfc556..064f96c33e 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -3,7 +3,8 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily -- refer to *types*, rather than *code* -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, RankNTypes #-} + module Hooks ( Hooks , emptyHooks , lookupHook @@ -107,8 +108,8 @@ data Hooks = Hooks , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ()) - , cmmToRawCmmHook :: Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroup () - -> IO (Stream IO RawCmmGroup ())) + , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a)) } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 1c27542270..391b989915 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -133,6 +133,7 @@ import CostCentre import ProfInit import TyCon import Name +import NameSet import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build @@ -173,6 +174,7 @@ import System.IO (fixIO) import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set) +import Data.Functor import Control.DeepSeq (force) import GHC.Iface.Ext.Ast ( mkHieFile ) @@ -1405,7 +1407,7 @@ hscWriteIface dflags iface no_change mod_location = do -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1464,11 +1466,11 @@ hscGenHardCode hsc_env cgguts location output_filename = do return a rawcmms1 = Stream.mapM dump rawcmms0 - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ()) + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 - return (output_filename, stub_c_exists, foreign_fps) + return (output_filename, stub_c_exists, foreign_fps, caf_infos) hscInteractive :: HscEnv @@ -1514,7 +1516,16 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename cmm_mod = mkModule (thisPackage dflags) mod_name - (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + cmmgroup <- + concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr cmmgroup) @@ -1535,7 +1546,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (Stream IO CmmGroup ()) + -> IO (Stream IO CmmGroupSRTs NameSet) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. @@ -1565,18 +1576,15 @@ doCodeGen hsc_env this_mod data_tycons pipeline_stream = {-# SCC "cmmPipeline" #-} - let run_pipeline = cmmPipeline hsc_env - in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 + Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + <&> (srtMapNonCAFs . moduleSRTMap) dump2 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) return a - ppr_stream2 = Stream.mapM dump2 pipeline_stream - - return ppr_stream2 - + return (Stream.mapM dump2 pipeline_stream) myCoreToStg :: DynFlags -> Module -> CoreProgram diff --git a/compiler/main/UpdateCafInfos.hs b/compiler/main/UpdateCafInfos.hs new file mode 100644 index 0000000000..c5e81150fe --- /dev/null +++ b/compiler/main/UpdateCafInfos.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-} + +module UpdateCafInfos + ( updateModDetailsCafInfos + ) where + +import GhcPrelude + +import CoreSyn +import HscTypes +import Id +import IdInfo +import InstEnv +import NameEnv +import NameSet +import Util +import Var +import Outputable + +#include "HsVersions.h" + +-- | Update CafInfos of all occurences (in rules, unfoldings, class instances) +updateModDetailsCafInfos + :: NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> ModDetails -- ^ ModDetails to update + -> ModDetails +updateModDetailsCafInfos non_cafs mod_details = + {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} + let + ModDetails{ md_types = type_env -- for unfoldings + , md_insts = insts + , md_rules = rules + } = mod_details + + -- type TypeEnv = NameEnv TyThing + ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env + -- Not strict! + + !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts + !rules' = strictMap (updateRuleCafInfos type_env') rules + in + mod_details{ md_types = type_env' + , md_insts = insts' + , md_rules = rules' + } + +-------------------------------------------------------------------------------- +-- Rules +-------------------------------------------------------------------------------- + +updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule +updateRuleCafInfos _ rule@BuiltinRule{} = rule +updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. } + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst +updateInstCafInfos type_env non_cafs = + updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs) + +-------------------------------------------------------------------------------- +-- TyThings +-------------------------------------------------------------------------------- + +updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing + +updateTyThingCafInfos type_env non_cafs (AnId id) = + AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id)) + +updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom + +-------------------------------------------------------------------------------- +-- Unfoldings +-------------------------------------------------------------------------------- + +updateIdUnfolding :: TypeEnv -> Id -> Id +updateIdUnfolding type_env id = + case idUnfolding id of + CoreUnfolding{ .. } -> + setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. } + DFunUnfolding{ .. } -> + setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. } + _ -> id + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- + +updateIdCafInfo :: NameSet -> Id -> Id +updateIdCafInfo non_cafs id + | idName id `elemNameSet` non_cafs + = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $ + id `setIdCafInfo` NoCafRefs + | otherwise + = id + +-------------------------------------------------------------------------------- + +updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr +-- Update occurrences of GlobalIds as directed by 'env' +-- The 'env' maps a GlobalId to a version with accurate CAF info +-- (and in due course perhaps other back-end-related info) +updateGlobalIds env e = go env e + where + go_id :: NameEnv TyThing -> Id -> Id + go_id env var = + case lookupNameEnv env (varName var) of + Nothing -> var + Just (AnId id) -> id + Just other -> pprPanic "UpdateCafInfos.updateGlobalIds" $ + text "Found a non-Id for Id Name" <+> ppr (varName var) $$ + nest 4 (text "Id:" <+> ppr var $$ + text "TyThing:" <+> ppr other) + + go :: NameEnv TyThing -> CoreExpr -> CoreExpr + go env (Var v) = Var (go_id env v) + go _ e@Lit{} = e + go env (App e1 e2) = App (go env e1) (go env e2) + go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e)) + go env (Let bs e) = Let (go_binds env bs) (go env e) + go env (Case e b ty alts) = + assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) + where + go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go env (Cast e c) = Cast (go env e) c + go env (Tick t e) = Tick t (go env e) + go _ e@Type{} = e + go _ e@Coercion{} = e + + go_binds :: NameEnv TyThing -> CoreBind -> CoreBind + go_binds env (NonRec b e) = + assertNotInNameEnv env [b] (NonRec b (go env e)) + go_binds env (Rec prs) = + assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs)) + +-- In `updateGlobaLIds` Names of local binders should not shadow Name of +-- globals. This assertion is to check that. +assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b +assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x |