diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2022-07-12 23:02:32 +0200 |
---|---|---|
committer | Andreas Klebinger <klebinger.andreas@gmx.at> | 2022-07-12 23:02:32 +0200 |
commit | 56ee1ba76f4295f82af8207518d284d0f63e7a92 (patch) | |
tree | 54b6a7a00430bb68fb31f354268ad04876a7149a | |
parent | 460505345e500eb902da9737c75c077d5fc5ef66 (diff) | |
download | haskell-56ee1ba76f4295f82af8207518d284d0f63e7a92.tar.gz |
Short out some more IND_STATIC during code generation.wip/andreask/ind-elim
When generating code for `f = g` use the cmm expression representing
`g` for all future references to `f`.
These would be eliminated via linker tricks anyway. But might save the
linker some work.
-rw-r--r-- | compiler/GHC/StgToCmm.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/DataCon.hs | 6 |
3 files changed, 22 insertions, 17 deletions
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 4efcf69d18..481a81c558 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -166,14 +166,15 @@ cgTopBinding logger tmpfs cfg = \case StgTopLifted (StgNonRec id rhs) -> do let (info, fcode) = cgTopRhs cfg NonRecursive id rhs fcode - addBindC info + info >>= addBindC StgTopLifted (StgRec pairs) -> do let (bndrs, rhss) = unzip pairs let pairs' = zip bndrs rhss r = unzipWith (cgTopRhs cfg Recursive) pairs' (infos, fcodes) = unzip r - addBindsC infos + infos' <- sequence infos + addBindsC infos' sequence_ fcodes StgTopStringLit id str -> do @@ -196,7 +197,7 @@ cgTopBinding logger tmpfs cfg = \case addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit) -cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) +cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (FCode CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 2ddba8ad18..08f530ba00 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -64,6 +64,7 @@ import GHC.Data.FastString import GHC.Data.List.SetOps import Control.Monad +import GHC.Utils.Trace (pprTraceM) ------------------------------------------------------------------------ -- Top-level bindings @@ -79,13 +80,13 @@ cgTopRhsClosure :: Platform -> UpdateFlag -> [Id] -- Args -> CgStgExpr - -> (CgIdInfo, FCode ()) + -> (FCode CgIdInfo, FCode ()) -cgTopRhsClosure platform rec id ccs upd_flag args body = +cgTopRhsClosure platform rec id ccs upd_flag args body = do let closure_label = mkClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args - in (cg_id_info, gen_code lf_info closure_label) + cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) + gen_code cg_id_info closure_label where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -102,12 +103,15 @@ cgTopRhsClosure platform rec id ccs upd_flag args body = -- gen_code _ closure_label | StgApp f [] <- body, null args, isNonRec rec - = do - cg_info <- getCgIdInfo f - emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] - - gen_code lf_info _closure_label - = do { profile <- getProfile + = ( do + cg_info <- getCgIdInfo f + return cg_info { cg_id = id } + , do + cg_info <- getCgIdInfo f + emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]) + + gen_code cg_info@CgIdInfo { cg_lf = lf_info } _closure_label + = (pure cg_info, do { profile <- getProfile ; let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription mod_name name @@ -125,7 +129,7 @@ cgTopRhsClosure platform rec id ccs upd_flag args body = ; forkClosureBody (closureCodeBody True id closure_info ccs args body fv_details) - ; return () } + ; return () }) unLit (CmmLit l) = l unLit _ = panic "unLit" diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 89bdb88058..8c6da534f1 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -64,7 +64,7 @@ cgTopRhsCon :: StgToCmmConfig -> DataCon -- Id -> ConstructorNumber -> [NonVoid StgArg] -- Args - -> (CgIdInfo, FCode ()) + -> (FCode CgIdInfo, FCode ()) cgTopRhsCon cfg id con mn args | Just static_info <- precomputedStaticConInfo_maybe cfg id con args , let static_code | isInternalName name = pure () @@ -75,11 +75,11 @@ cgTopRhsCon cfg id con mn args -- since importing modules will refer to it by name; -- but for Internal ones we can drop it altogether -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External - (static_info, static_code) + (pure static_info, static_code) -- Otherwise generate a closure for the constructor. | otherwise - = (id_Info, gen_code) + = (pure id_Info, gen_code) where platform = stgToCmmPlatform cfg |