From 12d8a7a3f48a9db4b77a745f08346fb5869b9cb0 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Tue, 10 Aug 2021 17:31:35 +0100 Subject: STG.Lift StaticPTr WIP Ticket #16981 --- compiler/GHC/Builtin/Types.hs | 37 +++++++++- compiler/GHC/Core/Lint.hs | 3 +- compiler/GHC/Core/Opt/SetLevels.hs | 3 +- compiler/GHC/Core/Type.hs | 12 ++-- compiler/GHC/Driver/Main.hs | 31 +++++--- compiler/GHC/Iface/Tidy.hs | 24 ++----- compiler/GHC/Iface/Tidy/StaticPtrTable.hs | 114 +----------------------------- compiler/GHC/Stg/Lift.hs | 15 +++- compiler/GHC/Stg/Lift/Analysis.hs | 10 ++- compiler/GHC/Stg/Lift/Monad.hs | 102 +++++++++++++++++++++++--- compiler/GHC/Stg/Pipeline.hs | 27 +++++-- compiler/GHC/Unit/Module/ModGuts.hs | 8 +-- 12 files changed, 208 insertions(+), 178 deletions(-) diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 3339842471..d8caee156c 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -5,9 +5,12 @@ Wired-in knowledge about {\em non-primitive} types -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#include "MachDeps.h" + -- | This module is about types that can be defined in Haskell, but which -- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim" module GHC.Builtin.Types ( @@ -152,7 +155,11 @@ module GHC.Builtin.Types ( integerINDataCon, integerINDataConName, naturalTy, naturalTyCon, naturalTyConName, naturalNSDataCon, naturalNSDataConName, - naturalNBDataCon, naturalNBDataConName + naturalNBDataCon, naturalNBDataConName, + + -- * Static Pointers + staticPtrInfoTyCon, staticPtrInfoDataCon, + staticPtrDataCon, staticPtrTyCon ) where @@ -2171,3 +2178,31 @@ filterCTuple (Exact n) | Just arity <- cTupleTyConNameArity_maybe n = Exact $ tupleTyConName BoxedTuple arity filterCTuple rdr = rdr + +staticPtrInfoDataCon :: DataCon +staticPtrInfoDataCon = pcDataCon staticPtrInfoDataConName [] [stringTy, stringTy, mkBoxedTupleTy [intTy, intTy] ] staticPtrInfoTyCon + +staticPtrInfoTyCon :: TyCon +staticPtrInfoTyCon = pcTyCon staticPtrInfoTyConName Nothing [] [staticPtrInfoDataCon] + + +staticPtrDataCon :: DataCon + +staticPtrDataCon = pcDataCon staticPtrDataConName alpha_tyvar + [ static_ptr_word_type + , static_ptr_word_type + , alphaTy + , mkTyConTy staticPtrInfoTyCon] + staticPtrTyCon + where + static_ptr_word_type = +#if WORD_SIZE_IN_BITS < 64 + word64PrimTy +#else + wordPrimTy +#endif + + + +staticPtrTyCon :: TyCon +staticPtrTyCon = pcTyCon staticPtrTyConName Nothing [alphaTyVar] [staticPtrDataCon] \ No newline at end of file diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 3b3a7232c0..5a547a180a 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -715,6 +715,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go go AllowAtTopLevel | (binders0, rhs') <- collectTyBinders rhs , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + , False = markAllJoinsBad $ foldr -- imitate @lintCoreExpr (Lam ...)@ @@ -983,7 +984,7 @@ lintIdOcc var nargs -- Check for a nested occurrence of the StaticPtr constructor. -- See Note [Checking StaticPtrs]. ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + ; when (False && nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ checkL (idName var /= makeStaticName) $ text "Found makeStatic nested in an expression" diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 2d69e8eb04..6a6ba8757f 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -83,8 +83,7 @@ import GHC.Core.Utils ( exprType, exprIsHNF , exprOkForSpeculation , exprIsTopLevelBindable , isExprLevPoly - , collectMakeStaticArgs - , mkLamTypes + , mkLamTypes, collectMakeStaticArgs ) import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) import GHC.Core.FVs -- all of it diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 6b88262ff5..99f35df5aa 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -1315,7 +1315,7 @@ piResultTy_maybe ty arg = case coreFullView ty of -- so we pay attention to efficiency, especially in the special case -- where there are no for-alls so we are just dropping arrows from -- a function type/kind. -piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys :: HasCallStack => Type -> [Type] -> Type piResultTys ty [] = ty piResultTys ty orig_args@(arg:args) | FunTy { ft_res = res } <- ty @@ -2245,7 +2245,7 @@ buildSynTyCon name binders res_kind roles rhs -- if it is surely unlifted, Nothing if we can't be sure (i.e., it is -- representation-polymorphic), and panics if the kind does not have the shape -- TYPE r. -isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe :: HasCallStack => Type -> Maybe Bool isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of ty' | isLiftedRuntimeRep ty' -> Just True TyConApp {} -> Just False -- Everything else is unlifted @@ -2255,7 +2255,7 @@ isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of -- representation polymorphism. -isUnliftedType :: HasDebugCallStack => Type -> Bool +isUnliftedType :: HasCallStack => Type -> Bool -- isUnliftedType returns True for forall'd unlifted types: -- x :: forall a. Int# -- I found bindings like these were getting floated to the top level. @@ -2299,13 +2299,13 @@ dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy -- | Extract the RuntimeRep classifier of a type. For instance, -- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not -- possible. -getRuntimeRep_maybe :: HasDebugCallStack +getRuntimeRep_maybe :: HasCallStack => Type -> Maybe Type getRuntimeRep_maybe = kindRep_maybe . typeKind -- | Extract the RuntimeRep classifier of a type. For instance, -- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type +getRuntimeRep :: HasCallStack => Type -> Type getRuntimeRep ty = case getRuntimeRep_maybe ty of Just r -> r @@ -2771,7 +2771,7 @@ See #14939. -} ----------------------------- -typeKind :: HasDebugCallStack => Type -> Kind +typeKind :: HasCallStack => Type -> Kind -- No need to expand synonyms typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys typeKind (LitTy l) = typeLiteralKind l diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index ea3040c64e..3bd93ac1ea 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -235,6 +235,9 @@ import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) import GHC.Data.Maybe +import GHC.LanguageExtensions +import GHC.Iface.Tidy.StaticPtrTable +import GHC.Utils.Trace {- ********************************************************************** %* * @@ -1550,16 +1553,20 @@ hscGenHardCode hsc_env cgguts location output_filename = do core_binds data_tycons ----------------- Convert to STG ------------------ - (stg_binds, denv, (caf_ccs, caf_cc_stacks)) + (stg_binds, spt_entries, denv, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} withTiming logger (text "CoreToStg"<+>brackets (ppr this_mod)) - (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ()) + (\(a, b, c, (d,e)) -> a `seqList` b `seqList` c `seq` d `seqList` e `seqList` ()) (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds) - + pprTraceM "main" (ppr spt_entries) let cost_centre_info = (local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags + + spt_init_code + | xopt StaticPointers dflags = sptModuleInitCode platform this_mod spt_entries + | otherwise = mempty prof_init | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info | otherwise = mempty @@ -1592,6 +1599,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init `appendStubC` cgIPEStub st + `appendStubC` spt_init_code (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} @@ -1614,8 +1622,8 @@ hscInteractive hsc_env cgguts location = do cg_binds = core_binds, cg_tycons = tycons, cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks, - cg_spt_entries = spt_entries } = cgguts + cg_modBreaks = mod_breaks + } = cgguts data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1627,7 +1635,7 @@ hscInteractive hsc_env cgguts location = do prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env this_mod location core_binds data_tycons - (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks) + (stg_binds, spt_entries, _infotable_prov, _caf_ccs__caf_cc_stacks) <- {-# SCC "CoreToStg" #-} myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds ----------------- Generate byte code ------------------ @@ -1784,7 +1792,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do (mkPseudoUniqueE 0) Many (exprType prepd_expr) - (stg_binds, prov_map, collected_ccs) <- + (stg_binds, _spt_entries, prov_map, collected_ccs) <- myCoreToStg logger dflags ictxt @@ -1798,6 +1806,7 @@ myCoreToStg :: Logger -> DynFlags -> InteractiveContext -> Bool -> Module -> ModLocation -> CoreProgram -> IO ( [StgTopBinding] -- output program + , [SptEntry] , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do @@ -1805,11 +1814,11 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod ml prepd_binds - stg_binds2 + (stg_binds2, spt_entries) <- {-# SCC "Stg2Stg" #-} stg2stg logger dflags ictxt for_bytecode this_mod stg_binds - return (stg_binds2, denv, cost_centre_info) + return (stg_binds2, spt_entries, denv, cost_centre_info) {- ********************************************************************** %* * @@ -1948,7 +1957,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons - (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks) + (stg_binds, spt_entries, _infotable_prov, _caf_ccs__caf_cc_stacks) <- {-# SCC "CoreToStg" #-} liftIO $ myCoreToStg (hsc_logger hsc_env) (hsc_dflags hsc_env) @@ -1966,7 +1975,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do _ <- liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg) + liftIO $ hscAddSptEntries hsc_env Nothing spt_entries let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 41b1ad6b9e..3b46feac70 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -17,7 +17,6 @@ module GHC.Iface.Tidy ( import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Backend import GHC.Driver.Ppr import GHC.Driver.Env @@ -41,7 +40,6 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class -import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env import GHC.Utils.Outputable @@ -51,7 +49,6 @@ import GHC.Utils.Trace import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err -import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var @@ -386,19 +383,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds - -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. - ; (spt_entries, tidy_binds') <- - sptCreateStaticBinds hsc_env mod tidy_binds - ; let { platform = targetPlatform (hsc_dflags hsc_env) - ; spt_init_code = sptModuleInitCode platform mod spt_entries - ; add_spt_init_code = - case backend dflags of - -- If we are compiling for the interpreter we will insert - -- any necessary SPT entries dynamically - Interpreter -> id - -- otherwise add a C stub to do so - _ -> (`appendStubC` spt_init_code) - + ; let { -- The completed type environment is gotten from -- a) the types and classes defined here (plus implicit things) -- b) adding Ids with correct IdInfo, including unfoldings, @@ -423,7 +408,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; tidy_rules = tidyRules tidy_env trimmed_rules ; -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' + all_tidy_binds = implicit_binds ++ tidy_binds -- Get the TyCons to generate code for. Careful! We must use -- the untidied TyCons here, because we need @@ -467,12 +452,11 @@ tidyProgram hsc_env (ModGuts { mg_module = mod cg_tycons = alg_tycons, cg_binds = all_tidy_binds, cg_ccs = S.toList local_ccs, - cg_foreign = add_spt_init_code foreign_stubs, + cg_foreign = foreign_stubs, cg_foreign_files = foreign_files, cg_dep_pkgs = dep_direct_pkgs deps, cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks, - cg_spt_entries = spt_entries }, + cg_modBreaks = modBreaks }, ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index ad7c1a3ec8..b6d2af1445 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -48,8 +48,7 @@ -- module GHC.Iface.Tidy.StaticPtrTable - ( sptCreateStaticBinds - , sptModuleInitCode + ( sptModuleInitCode ) where {- Note [Grand plan for static forms] @@ -126,36 +125,18 @@ Here is a running example: import GHC.Prelude import GHC.Platform -import GHC.Driver.Session -import GHC.Driver.Env - -import GHC.Core -import GHC.Core.Utils (collectMakeStaticArgs) -import GHC.Core.DataCon -import GHC.Core.Make (mkStringExprFSWith) -import GHC.Core.Type - import GHC.Cmm.CLabel import GHC.Unit.Module import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Builtin.Names -import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Linker.Types -import GHC.Types.Name import GHC.Types.Id -import GHC.Types.TyThing import GHC.Types.ForeignStubs -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Strict -import Data.List (intercalate) -import Data.Maybe import GHC.Fingerprint -import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Trace -- | Replaces all bindings of the form -- @@ -170,95 +151,6 @@ import qualified GHC.LanguageExtensions as LangExt -- -- It also yields the C stub that inserts these bindings into the static -- pointer table. -sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO ([SptEntry], CoreProgram) -sptCreateStaticBinds hsc_env this_mod binds - | not (xopt LangExt.StaticPointers dflags) = - return ([], binds) - | otherwise = do - -- Make sure the required interface files are loaded. - _ <- lookupGlobal hsc_env unpackCStringName - (fps, binds') <- evalStateT (go [] [] binds) 0 - return (fps, binds') - where - go fps bs xs = case xs of - [] -> return (reverse fps, reverse bs) - bnd : xs' -> do - (fps', bnd') <- replaceStaticBind bnd - go (reverse fps' ++ fps) (bnd' : bs) xs' - - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - - -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. - -- - -- The 'Int' state is used to produce a different key for each binding. - replaceStaticBind :: CoreBind - -> StateT Int IO ([SptEntry], CoreBind) - replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e - return (maybeToList mfp, NonRec b' e') - replaceStaticBind (Rec rbs) = do - (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs - return (catMaybes mfps, Rec rbs') - - replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) - replaceStatic b e@(collectTyBinders -> (tvs, e0)) = - case collectMakeStaticArgs e0 of - Nothing -> return (Nothing, (b, e)) - Just (_, t, info, arg) -> do - (fp, e') <- mkStaticBind t info arg - return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) - - mkStaticBind :: Type -> CoreExpr -> CoreExpr - -> StateT Int IO (Fingerprint, CoreExpr) - mkStaticBind t srcLoc e = do - i <- get - put (i + 1) - staticPtrInfoDataCon <- - lift $ lookupDataConHscEnv staticPtrInfoDataConName - let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i - info <- mkConApp staticPtrInfoDataCon <$> - (++[srcLoc]) <$> - mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitFS $ moduleUnit this_mod - , moduleNameFS $ moduleName this_mod - ] - - -- The module interface of GHC.StaticPtr should be loaded at least - -- when looking up 'fromStatic' during type-checking. - staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName - return (fp, mkConApp staticPtrDataCon - [ Type t - , mkWord64LitWordRep platform w0 - , mkWord64LitWordRep platform w1 - , info - , e ]) - - mkStaticPtrFingerprint :: Int -> Fingerprint - mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" - [ unitString $ moduleUnit this_mod - , moduleNameString $ moduleName this_mod - , show n - ] - - -- Choose either 'Word64#' or 'Word#' to represent the arguments of the - -- 'Fingerprint' data constructor. - mkWord64LitWordRep platform = - case platformWordSize platform of - PW4 -> mkWord64LitWord64 - PW8 -> mkWordLit platform . toInteger - - lookupIdHscEnv :: Name -> IO Id - lookupIdHscEnv n = lookupType hsc_env n >>= - maybe (getError n) (return . tyThingId) - - lookupDataConHscEnv :: Name -> IO DataCon - lookupDataConHscEnv n = lookupType hsc_env n >>= - maybe (getError n) (return . tyThingDataCon) - - getError n = pprPanic "sptCreateStaticBinds.get: not found" $ - text "Couldn't find" <+> ppr n -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries -- of @module@ into the static pointer table. @@ -267,7 +159,7 @@ sptCreateStaticBinds hsc_env this_mod binds -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub sptModuleInitCode _ _ [] = mempty -sptModuleInitCode platform this_mod entries = CStub $ vcat +sptModuleInitCode platform this_mod entries = CStub $ pprTraceIt "init" $ vcat [ text "static void hs_spt_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));" , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index f83ccd388f..b3cb8f28ea 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -30,6 +30,10 @@ import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing ) +import GHC.Utils.Trace +import GHC.Builtin.Names +import GHC.Unit.Module +import GHC.Linker.Types -- Note [Late lambda lifting in STG] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -124,8 +128,8 @@ import Data.Maybe ( isNothing ) -- -- (Mostly) textbook instance of the lambda lifting transformation, selecting -- which bindings to lambda lift by consulting 'goodToLift'. -stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding] -stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ()) +stgLiftLams :: Module -> DynFlags -> UniqSupply -> [InStgTopBinding] -> ([OutStgTopBinding], [SptEntry]) +stgLiftLams this_mod dflags us = runLiftM this_mod dflags us . foldr liftTopLvl (pure ()) liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM () liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do @@ -180,6 +184,7 @@ withLiftedBindPairs top rec pairs scope k = do when (isRec rec) startBindingGroup rhss' <- traverse (liftRhs (Just abs_ids)) rhss let pairs' = zip bndrs' rhss' + pprTraceM "LIFTING" (ppr bndrs) addLiftedBinding (mkStgBinding rec pairs') when (isRec rec) endBindingGroup k Nothing @@ -220,6 +225,12 @@ liftArgs (StgVarArg occ) = do liftExpr :: LlStgExpr -> LiftM OutStgExpr liftExpr (StgLit lit) = pure (StgLit lit) liftExpr (StgTick t e) = StgTick t <$> liftExpr e +liftExpr (StgApp f args) + | idName f == makeStaticName + , [cc_info, payload] <- args = do + cc_info' <- liftArgs cc_info + payload' <- liftArgs payload + addStaticPtrBinding cc_info' payload' liftExpr (StgApp f args) = do f' <- substOcc f args' <- traverse liftArgs args diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 5999104c9c..05f704e965 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -38,6 +38,7 @@ import GHC.Utils.Misc import GHC.Types.Var.Set import Data.Maybe ( mapMaybe ) +import GHC.Utils.Trace -- Note [When to lift] -- ~~~~~~~~~~~~~~~~~~~ @@ -107,8 +108,8 @@ import Data.Maybe ( mapMaybe ) -- . llTrace :: String -> SDoc -> a -> a -llTrace _ _ c = c --- llTrace a b c = pprTrace a b c +--llTrace _ _ c = c +llTrace a b c = pprTrace a b c type instance BinderP 'LiftLams = BinderInfo type instance XRhsClosure 'LiftLams = DIdSet @@ -467,6 +468,11 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide $ freeVarsOfRhs rhs clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope + + is_static_rhs = case rhss of + [StgRhsClosure _ _ _ binders body] -> pprTrace "is_static" (ppr binders $$ pprStgExpr shortStgPprOpts body) False + _ -> pprTrace "rhs" (vcat (map (pprStgRhs shortStgPprOpts) rhss)) False + rhsLambdaBndrs :: LlStgRhs -> [Id] rhsLambdaBndrs StgRhsCon{} = [] rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 9b29b02ba6..6110e3b809 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -13,7 +13,7 @@ module GHC.Stg.Lift.Monad ( -- * Transformation monad LiftM, runLiftM, -- ** Adding bindings - startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, + startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, addStaticPtrBinding, -- ** Substitution and binders withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs, -- ** Occurrences @@ -46,6 +46,19 @@ import Control.Monad.Trans.RWS.Strict ( RWST, runRWST ) import qualified Control.Monad.Trans.RWS.Strict as RWS import Control.Monad.Trans.Cont ( ContT (..) ) import Data.ByteString ( ByteString ) +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Builtin.Types +import GHC.Linker.Types +import GHC.Types.Unique +import GHC.Fingerprint +import GHC.Unit.Module +import Data.List (intercalate) +import GHC.Types.Literal +import GHC.Platform +import Data.Maybe +import GHC.LanguageExtensions +import GHC.Types.SrcLoc -- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@ decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)]) @@ -80,10 +93,11 @@ data Env -- 'InId's to 'OutId's. -- -- Invariant: 'Id's not present in this map won't be substituted. + , e_mod :: !Module } -emptyEnv :: DynFlags -> Env -emptyEnv dflags = Env dflags emptySubst emptyVarEnv +emptyEnv :: Module -> DynFlags -> Env +emptyEnv this_mod dflags = Env dflags emptySubst emptyVarEnv this_mod -- Note [Handling floats] @@ -145,6 +159,7 @@ data FloatLang | EndBindingGroup | PlainTopBinding OutStgTopBinding | LiftedBinding OutStgBinding + | LiftedStaticBinding SptEntry Id StgRhs instance Outputable FloatLang where ppr StartBindingGroup = char '(' @@ -154,10 +169,11 @@ instance Outputable FloatLang where ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs) where (rec, pairs) = decomposeStgBinding bind + ppr (LiftedStaticBinding _spt binder _bind) = ppr binder -- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats". --- Important pre-conditions: The nesting of opening 'StartBindinGroup's and --- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding +-- Important pre-conditions: The nesting of opening 'StartBindingGroup's and +-- closing 'EndBindingGroup's is balanced. Also, it is crucial that every binding -- group has at least one recursive binding inside. Otherwise there's no point -- in announcing the binding group in the first place and an @ASSERT@ will -- trigger. @@ -178,6 +194,9 @@ collectFloats = go (0 :: Int) [] LiftedBinding bind | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest | otherwise -> go n (bind:binds) rest + LiftedStaticBinding _ binder bind + | n == 0 -> StgTopLifted (StgNonRec binder bind) : go n binds rest + | otherwise -> go n (StgNonRec binder bind : binds) rest map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding rm_cccs = map_rhss removeRhsCCCS @@ -186,6 +205,12 @@ collectFloats = go (0 :: Int) [] is_rec StgRec{} = True is_rec _ = False +collectSPTEntries :: [FloatLang] -> [SptEntry] +collectSPTEntries = mapMaybe go + where + go (LiftedStaticBinding spt_entry _ _) = Just spt_entry + go _ = Nothing + -- | Omitting this makes for strange closure allocation schemes that crash the -- GC. removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass @@ -222,10 +247,14 @@ instance MonadUnique LiftM where getUniqueM = LiftM (lift getUniqueM) getUniquesM = LiftM (lift getUniquesM) -runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding] -runLiftM dflags us (LiftM m) = collectFloats (fromOL floats) +runLiftM :: Module -> DynFlags -> UniqSupply -> LiftM () -> ([OutStgTopBinding], [SptEntry]) +runLiftM this_mod dflags us (LiftM m) = (collectFloats (fromOL floats), spt_entries) where - (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ()) + spt_entries + | xopt StaticPointers dflags = collectSPTEntries final_floats + | otherwise = [] + final_floats = fromOL floats + (_, _, floats) = initUs_ us (runRWST m (emptyEnv this_mod dflags) ()) -- | Writes a plain 'StgTopStringLit' to the output. addTopStringLit :: OutId -> ByteString -> LiftM () @@ -245,6 +274,61 @@ endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup addLiftedBinding :: OutStgBinding -> LiftM () addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding +addLiftedStaticPtrBinding :: SptEntry -> Id -> StgRhs -> LiftM () +addLiftedStaticPtrBinding spt_entry binder bind = + LiftM . RWS.tell . unitOL $ LiftedStaticBinding spt_entry binder bind + +newStaticPtrBndr :: Unique -> Module -> Type -> Id +newStaticPtrBndr uniq this_mod ty = + let str = "$static_ptr" ++ show uniq + in mkVanillaGlobal + -- This makes and external name but *doesn't* add it to the name cache, + -- this is safe because the name is only, and can only be, referenced from the + -- SPT init stub. + (mkExternalName uniq this_mod (mkVarOcc str) noSrcSpan) + (mkTyConApp staticPtrTyCon [ty]) + +addStaticPtrBinding :: StgArg -> StgArg -> LiftM StgExpr +addStaticPtrBinding loc payload = do + uniq <- getUniqueM + uniq_info <- getUniqueM + this_mod <- LiftM $ RWS.asks e_mod + platform <- targetPlatform <$> (LiftM $ RWS.asks e_dflags) + let binder_ptr = newStaticPtrBndr uniq this_mod (stgArgType payload) + binder_info = mkSysLocal (mkFastString "$static_ptr_info") uniq_info Many (mkTyConTy staticPtrInfoTyCon) + fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint this_mod uniq + unit_lit = LitString (bytesFS $ unitFS $ moduleUnit this_mod) + mod_name_lit = LitString (bytesFS $ moduleNameFS $ moduleName this_mod) + + info = StgRhsCon dontCareCCS staticPtrInfoDataCon NoNumber [] [StgLitArg unit_lit, StgLitArg mod_name_lit, loc] + + ptr = StgRhsCon dontCareCCS staticPtrDataCon NoNumber [] + [ StgLitArg (mkWord64LitWordRep platform (toInteger w0)) + , StgLitArg (mkWord64LitWordRep platform (toInteger w1)) + , StgVarArg binder_info + , payload] + + spt_entry = SptEntry binder_ptr fp + addLiftedBinding (StgNonRec binder_info info) + addLiftedStaticPtrBinding spt_entry binder_ptr ptr + return (StgApp binder_ptr []) + + where + mkStaticPtrFingerprint :: Module -> Unique -> Fingerprint + mkStaticPtrFingerprint this_mod n = fingerprintString $ intercalate ":" + [ unitString $ moduleUnit this_mod + , moduleNameString $ moduleName this_mod + , show n + ] + + -- Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep :: Platform -> Integer -> Literal + mkWord64LitWordRep platform = + case platformWordSize platform of + PW4 -> mkLitWord64 + PW8 -> mkLitWord platform . toInteger + -- | Takes a binder and a continuation which is called with the substituted -- binder. The continuation will be evaluated in a 'LiftM' context in which that -- binder is deemed in scope. Think of it as a 'RWS.local' computation: After @@ -283,6 +367,8 @@ withLiftedBndr abs_ids bndr inner = do }) (unwrapLiftM (inner bndr')) +-- | Create a new exported vanilla id for the static pointer + -- | See 'withLiftedBndr'. withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index b0e1848f19..40ac929c42 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -33,6 +33,10 @@ import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import GHC.Utils.Trace +import GHC.Linker.Types +import Data.IORef +import GHC.LanguageExtensions newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } deriving (Functor, Applicative, Monad, MonadIO) @@ -52,13 +56,14 @@ stg2stg :: Logger -> Bool -- prepare for bytecode? -> Module -- module being compiled -> [StgTopBinding] -- input program - -> IO [StgTopBinding] -- output program + -> IO ([StgTopBinding], [SptEntry]) -- output program stg2stg logger dflags ictxt for_bytecode this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" + ; spt_entries_var <- newIORef [] -- Do the main business! ; binds' <- runStgM 'g' $ - foldM do_stg_pass binds (getStgToDo for_bytecode dflags) + foldM (do_stg_pass spt_entries_var) binds (getStgToDo for_bytecode dflags) -- Dependency sort the program as last thing. The program needs to be -- in dependency order for the SRT algorithm to work (see @@ -69,7 +74,8 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds -- preserve the order or only create minimal recursive groups, so a -- sorting pass is necessary. ; let binds_sorted = depSortStgPgm this_mod binds' - ; return binds_sorted + ; spt_entries <- readIORef spt_entries_var + ; return (binds_sorted, spt_entries) } where @@ -80,8 +86,8 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds = \ _whodunnit _binds -> return () ------------------------------------------- - do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] - do_stg_pass binds to_do + do_stg_pass :: IORef [SptEntry] -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] + do_stg_pass spt_result binds to_do = case to_do of StgDoNothing -> return binds @@ -94,8 +100,11 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds end_pass "StgCse" binds' StgLiftLams -> do + pprTraceM "running lift" empty us <- getUniqueSupplyM - let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds + let (binds', spt_entries) = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod dflags us binds + pprTraceM "spt_entries" (ppr spt_entries) + liftIO $ writeIORef spt_result spt_entries end_pass "StgLiftLams" binds' StgBcPrep -> do @@ -149,11 +158,15 @@ getStgToDo for_bytecode dflags = -- Important that unarisation comes first -- See Note [StgCse after unarisation] in GHC.Stg.CSE , optional Opt_StgCSE StgCSE - , optional Opt_StgLiftLams StgLiftLams + , runWhen run_lift StgLiftLams , runWhen for_bytecode StgBcPrep , optional Opt_StgStats StgStats ] where optional opt = runWhen (gopt opt dflags) + -- The LiftLams pass lifts static forms to the top-level, this is necessary + -- for correctness so the pass is always run when StaticPointers is enabled. + -- See [Grand plan for static forms] + run_lift = gopt Opt_StgLiftLams dflags || xopt StaticPointers dflags mandatory = id runWhen :: Bool -> StgToDo -> StgToDo diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index e799ebf2a1..98c65bcb9a 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -22,8 +22,6 @@ import GHC.Core ( CoreProgram, CoreRule ) import GHC.Core.TyCon import GHC.Core.PatSyn -import GHC.Linker.Types ( SptEntry(..) ) - import GHC.Types.Annotations ( Annotation ) import GHC.Types.Avail import GHC.Types.CompleteMatch @@ -138,9 +136,5 @@ data CgGuts cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints - cg_spt_entries :: [SptEntry] - -- ^ Static pointer table entries for static forms defined in - -- the module. - -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable" + cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints } -- cgit v1.2.1