[Git][ghc/ghc][wip/osa1/lfinfo] Refactor types to eliminate bottom fields
Ömer Sinan Ağacan
gitlab at gitlab.haskell.org
Tue Mar 24 08:03:06 UTC 2020
Ömer Sinan Ağacan pushed to branch wip/osa1/lfinfo at Glasgow Haskell Compiler / GHC
Commits:
168a1ebb by Ömer Sinan Ağacan at 2020-03-24T11:02:45+03:00
Refactor types to eliminate bottom fields
- - - - -
21 changed files:
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Env.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToCmm/Types.hs
- compiler/basicTypes/Id.hs
- compiler/basicTypes/IdInfo.hs
- compiler/main/UpdateCafInfos.hs
- testsuite/tests/codeGen/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T4201.stdout
Changes:
=====================================
compiler/GHC/ByteCode/InfoTable.hs
=====================================
@@ -15,9 +15,9 @@ import GHC.ByteCode.Types
import GHC.Runtime.Interpreter
import GHC.Driver.Session
import GHC.Driver.Types
+import GHC.Core.DataCon
import Name ( Name, getName )
import NameEnv
-import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import GHC.Types.RepType
import GHC.StgToCmm.Layout ( mkVirtConstrSizes )
@@ -69,7 +69,7 @@ make_constr_itbls hsc_env cons =
| ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
| otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
- descr = dataConIdentity dcon
+ descr = dataConIdentity (dataConName dcon)
r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
conNo (tagForCon dflags dcon) descr)
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -1339,17 +1339,16 @@ dataConRepArgTys (MkData { dcRep = rep
-- | The string @package:module.name@ identifying a constructor, which is attached
-- to its info table and used by the GHCi debugger and the heap profiler
-dataConIdentity :: DataCon -> ByteString
+dataConIdentity :: Name -> ByteString
-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
-dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
+dataConIdentity name = LBS.toStrict $ BSB.toLazyByteString $ mconcat
[ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod))
, BSB.int8 $ fromIntegral (ord ':')
, BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))
, BSB.int8 $ fromIntegral (ord '.')
, BSB.byteString $ bytesFS (occNameFS (nameOccName name))
]
- where name = dataConName dc
- mod = ASSERT( isExternalName name ) nameModule name
+ where mod = ASSERT( isExternalName name ) nameModule name
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]
+{-# LANGUAGE LambdaCase #-}
-- | Functions for converting Core things to interface file things.
module GHC.CoreToIface
@@ -442,8 +443,7 @@ toIfaceIdDetails (RecSelId { sel_naughty = n
-- The remaining cases are all "implicit Ids" which don't
-- appear in interface files at all
-toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
- IfVanillaId -- Unexpected; the other
+toIfaceIdDetails _ = IfVanillaId -- Unexpected; the other
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
@@ -626,18 +626,14 @@ toIfaceVar v
---------------------
-toIfaceLFInfo :: LambdaFormInfo -> IfaceLFInfo
-toIfaceLFInfo (LFReEntrant TopLevel oneshot rep fvs_flag _argdesc) =
- IfLFReEntrant (toIfaceOneShot oneshot) rep fvs_flag
-toIfaceLFInfo (LFThunk TopLevel hasfv updateable sfi m_function) =
- -- Assert that arity fits in 14 bits
- ASSERT(fromEnum hasfv <= 1 && fromEnum updateable <= 1 && fromEnum m_function <= 1)
- IfLFThunk hasfv updateable (toIfaceStandardFormInfo sfi) m_function
-toIfaceLFInfo LFUnlifted = IfLFUnlifted
-toIfaceLFInfo (LFCon con) = IfLFCon (dataConName con)
--- All other cases are not possible at the top level.
-toIfaceLFInfo lf = pprPanic "Invalid IfaceLFInfo conversion:"
- (ppr lf <+> text "should not be exported")
+toIfaceLFInfo :: ImportedLFI -> IfaceLFInfo
+toIfaceLFInfo = \case
+ LFReEntrant lfr -> IfLFReEntrant (lfr_rep_arity lfr)
+ LFThunk lft -> IfLFThunk (lft_updatable lft) (toIfaceStandardFormInfo (lft_sfi lft)) (lft_mb_fun lft)
+ LFCon name _ -> IfLFCon name
+ LFUnknown mb_fun -> IfLFUnknown mb_fun
+ LFUnlifted -> IfLFUnlifted
+ LFLetNoEscape -> panic "toIfaceLFInfo: LFLetNoEscape"
toIfaceStandardFormInfo :: StandardFormInfo -> IfaceStandardFormInfo
toIfaceStandardFormInfo NonStandardThunk = IfStandardFormInfo 1
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -389,8 +389,8 @@ data IfaceIdDetails
-- Lambda form info
data IfaceLFInfo
- = IfLFReEntrant !IfaceOneShot !RepArity !Bool
- | IfLFThunk !Bool !Bool !IfaceStandardFormInfo !Bool
+ = IfLFReEntrant !RepArity
+ | IfLFThunk !Bool !IfaceStandardFormInfo !Bool
| IfLFCon -- A saturated constructor application
!Name -- The constructor Name
| IfLFUnknown !Bool
@@ -407,10 +407,10 @@ tcStandardFormInfo (IfStandardFormInfo w)
| otherwise = SelectorThunk
instance Outputable IfaceLFInfo where
- ppr (IfLFReEntrant oneshot rep fvs_flag) =
- text "LFReEntrant" <+> ppr (oneshot, rep, fvs_flag)
- ppr (IfLFThunk fvs_flag upd_flag sfi fun_flag) =
- text "LFThunk" <+> ppr (fvs_flag, upd_flag, fun_flag) <+> ppr (tcStandardFormInfo sfi)
+ ppr (IfLFReEntrant arity) =
+ text "LFReEntrant" <+> ppr arity
+ ppr (IfLFThunk updatable sfi mb_fun) =
+ text "LFThunk" <+> ppr (updatable, tcStandardFormInfo sfi, mb_fun)
ppr (IfLFCon con) = text "LFCon" <> brackets (ppr con)
ppr IfLFUnlifted = text "LFUnlifted"
ppr (IfLFUnknown fun_flag) = text "LFUnknown" <+> ppr fun_flag
@@ -423,17 +423,14 @@ instance Binary IfaceStandardFormInfo where
instance Binary IfaceLFInfo where
-- TODO: We could pack the bytes somewhat
- put_ bh (IfLFReEntrant oneshot rep fvs_flag) = do
+ put_ bh (IfLFReEntrant arity) = do
putByte bh 0
- put_ bh oneshot
- put_ bh rep
- put_ bh fvs_flag
- put_ bh (IfLFThunk top_lvl no_fvs std_form maybe_fun) = do
+ put_ bh arity
+ put_ bh (IfLFThunk updatable sfi mb_fun) = do
putByte bh 1
- put_ bh top_lvl
- put_ bh no_fvs
- put_ bh std_form
- put_ bh maybe_fun
+ put_ bh updatable
+ put_ bh sfi
+ put_ bh mb_fun
put_ bh (IfLFCon con_name) = do
putByte bh 2
put_ bh con_name
@@ -445,8 +442,8 @@ instance Binary IfaceLFInfo where
get bh = do
tag <- getByte bh
case tag of
- 0 -> IfLFReEntrant <$> get bh <*> get bh <*> get bh
- 1 -> IfLFThunk <$> get bh <*> get bh <*> get bh <*> get bh
+ 0 -> IfLFReEntrant <$> get bh
+ 1 -> IfLFThunk <$> get bh <*> get bh <*> get bh
2 -> IfLFCon <$> get bh
3 -> IfLFUnknown <$> get bh
4 -> pure IfLFUnlifted
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1507,16 +1507,17 @@ addIdLFInfo id = case idLFInfo_maybe id of
Just _ -> id
-- Make a LambdaFormInfo for the Ids without a LFInfo in the iface file
-mkLFImported :: IdDetails -> IdInfo -> Type -> LambdaFormInfo
+mkLFImported :: IdDetails -> IdInfo -> Type -> ImportedLFI
mkLFImported details info ty
| DataConWorkId con <- details
, isNullaryRepDataCon con
- = LFCon con -- An imported nullary constructor
+ = LFCon (dataConName con) (dataConTag con)
+ -- An imported nullary constructor
-- We assume that the constructor is evaluated so that
-- the id really does point directly to the constructor
| arity > 0
- = LFReEntrant TopLevel noOneShotInfo arity True ArgUnknown
+ = LFReEntrant (LFR_Imported arity)
| isUnliftedType ty
= LFUnlifted
@@ -1533,16 +1534,18 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
-tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
-tcLFInfo (IfLFReEntrant oneshot rep fvs_flag) =
- return (LFReEntrant TopLevel (tcIfaceOneShot oneshot) rep fvs_flag ArgUnknown)
+tcLFInfo :: IfaceLFInfo -> IfL ImportedLFI
-tcLFInfo (IfLFThunk fvs_flag upd_flag sfi fun_flag ) = do
- return (LFThunk TopLevel fvs_flag upd_flag (tcStandardFormInfo sfi) fun_flag)
+tcLFInfo (IfLFReEntrant arity) = return (LFReEntrant (LFR_Imported arity))
+
+tcLFInfo (IfLFThunk updatable sfi mb_fun) =
+ return (LFThunk (LFT_Imported updatable (tcStandardFormInfo sfi) mb_fun))
tcLFInfo IfLFUnlifted = return LFUnlifted
-tcLFInfo (IfLFCon con_name) = LFCon <$!> tcIfaceDataCon con_name
+tcLFInfo (IfLFCon name) = do
+ con <- tcIfaceDataCon name
+ return (LFCon name (dataConTag con))
tcLFInfo (IfLFUnknown fun_flag) = return (LFUnknown fun_flag)
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -26,7 +26,7 @@ import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Types (ModuleLFInfos)
+import GHC.StgToCmm.Types (ModuleLFInfos, toImportedLFI)
import GHC.Cmm
import GHC.Cmm.CLabel
@@ -112,15 +112,14 @@ codeGen dflags this_mod data_tycons
-- Only external names are actually visible to codeGen. So they are the
-- only ones we care about.
- ; let extractInfo info = lf `seq` Just (name,lf)
- where
- id = cg_id info
- !name = idName id
- lf = cg_lf info
+ ; let extractInfo (CgIdInfo !id !lf _) =
+ let !lf' = toImportedLFI lf
+ !name = idName id
+ in Just (name, lf')
; let !generatedInfo = mkNameEnv (mapMaybe extractInfo (eltsUFM cg_id_infos))
- ; return $! generatedInfo
+ ; return generatedInfo
}
---------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -15,6 +15,7 @@ module GHC.StgToCmm.Bind (
import GhcPrelude hiding ((<*>))
+import GHC.StgToCmm.Types
import GHC.StgToCmm.Expr
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
@@ -374,7 +375,7 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body
-------------------------
cgRhsStdThunk
:: Id
- -> LambdaFormInfo
+ -> LocalLFI
-> [StgArg] -- payload
-> FCode (CgIdInfo, FCode CmmAGraph)
@@ -418,7 +419,7 @@ mkClosureLFInfo :: DynFlags
-> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> LambdaFormInfo
+ -> LocalLFI
mkClosureLFInfo dflags bndr top fvs upd_flag args
| null args =
mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
@@ -524,7 +525,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
-load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
+load_fvs :: LocalReg -> LocalLFI -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs node lf_info = mapM_ (\ (reg, off) ->
do dflags <- getDynFlags
platform <- getPlatform
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards #-}
+{-# LANGUAGE CPP, RecordWildCards, ImplicitParams, GADTs #-}
-----------------------------------------------------------------------------
--
@@ -50,7 +50,6 @@ module GHC.StgToCmm.Closure (
-- These are really just functions on LambdaFormInfo
closureUpdReqd, closureSingleEntry,
closureReEntrant, closureFunInfo,
- isToplevClosure,
mightBeAFunction,
blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep
@@ -118,10 +117,10 @@ instance Outputable CgLoc where
type SelfLoopInfo = (Id, BlockId, [LocalReg])
-- used by ticky profiling
-isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun :: LambdaFormInfo a -> Bool
isKnownFun LFReEntrant{} = True
isKnownFun LFLetNoEscape = True
-isKnownFun _ = False
+isKnownFun _ = False
-------------------------------------
@@ -194,7 +193,7 @@ argPrimRep arg = typePrimRep1 (stgArgType arg)
-- Building LambdaFormInfo
------------------------------------------------------
-mkLFArgument :: Id -> LambdaFormInfo
+mkLFArgument :: Id -> LambdaFormInfo a
mkLFArgument id
| isUnliftedType ty = LFUnlifted
| mightBeAFunction ty = LFUnknown True
@@ -203,7 +202,7 @@ mkLFArgument id
ty = idType id
-------------
-mkLFLetNoEscape :: LambdaFormInfo
+mkLFLetNoEscape :: LambdaFormInfo a
mkLFLetNoEscape = LFLetNoEscape
-------------
@@ -211,22 +210,19 @@ mkLFReEntrant :: TopLevelFlag -- True of top level
-> [Id] -- Free vars
-> [Id] -- Args
-> ArgDescr -- Argument descriptor
- -> LambdaFormInfo
+ -> LocalLFI
mkLFReEntrant _ _ [] _
= pprPanic "mkLFReEntrant" empty
mkLFReEntrant top fvs args arg_descr
- = LFReEntrant top os_info (length args) (null fvs) arg_descr
+ = LFReEntrant (LFR_Local top os_info (length args) (null fvs) arg_descr)
where os_info = idOneShotInfo (head args)
-------------
-mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LocalLFI
mkLFThunk thunk_ty top fvs upd_flag
= ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
- LFThunk top (null fvs)
- (isUpdatable upd_flag)
- NonStandardThunk
- (mightBeAFunction thunk_ty)
+ LFThunk (LFT_Local top (null fvs) (isUpdatable upd_flag) NonStandardThunk (mightBeAFunction thunk_ty))
--------------
mightBeAFunction :: Type -> Bool
@@ -241,23 +237,21 @@ mightBeAFunction ty
= True
-------------
-mkConLFInfo :: DataCon -> LambdaFormInfo
-mkConLFInfo con = LFCon con
+mkConLFInfo :: DataCon -> LambdaFormInfo a
+mkConLFInfo con = LFCon (dataConName con) (dataConTag con)
-------------
-mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
+mkSelectorLFInfo :: Id -> Int -> Bool -> LocalLFI
mkSelectorLFInfo id offset updatable
- = LFThunk NotTopLevel False updatable (SelectorThunk offset)
- (mightBeAFunction (idType id))
+ = LFThunk (LFT_Local NotTopLevel False updatable (SelectorThunk offset) (mightBeAFunction (idType id)))
-------------
-mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LocalLFI
mkApLFInfo id upd_flag arity
- = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
- (mightBeAFunction (idType id))
+ = LFThunk (LFT_Local NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) (mightBeAFunction (idType id)))
-------------
-mkLFStringLit :: LambdaFormInfo
+mkLFStringLit :: LambdaFormInfo a
mkLFStringLit = LFUnlifted
-----------------------------------------------------
@@ -295,37 +289,37 @@ tagForArity dflags arity
| isSmallFamily dflags arity = arity
| otherwise = 0
-lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
+lfDynTag :: DynFlags -> LambdaFormInfo a -> DynTag
-- Return the tag in the low order bits of a variable bound
-- to this LambdaForm
-lfDynTag dflags (LFCon con) = tagForCon dflags con
-lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
-lfDynTag _ _other = 0
-
+lfDynTag dflags lfi =
+ case lfi of
+ LFCon _ tag -> min tag (mAX_PTR_TAG dflags)
+ LFReEntrant lfr -> tagForArity dflags (lfr_rep_arity lfr)
+ _ -> 0
-----------------------------------------------------------------------------
-- Observing LambdaFormInfo
-----------------------------------------------------------------------------
------------
-isLFThunk :: LambdaFormInfo -> Bool
-isLFThunk (LFThunk {}) = True
+isLFThunk :: LambdaFormInfo a -> Bool
+isLFThunk LFThunk{} = True
isLFThunk _ = False
-isLFReEntrant :: LambdaFormInfo -> Bool
-isLFReEntrant (LFReEntrant {}) = True
-isLFReEntrant _ = False
+isLFReEntrant :: LambdaFormInfo a -> Bool
+isLFReEntrant LFReEntrant{} = True
+isLFReEntrant _ = False
-----------------------------------------------------------------------------
-- Choosing SM reps
-----------------------------------------------------------------------------
-lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
-lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
-lfClosureType (LFCon con) = Constr (dataConTagZ con)
- (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
-lfClosureType _ = panic "lfClosureType"
+lfClosureType :: LocalLFI -> ClosureTypeInfo
+lfClosureType (LFReEntrant lfr) = Fun (lfr_rep_arity lfr) (lfr_arg_descr lfr)
+lfClosureType (LFCon name tag) = Constr (tag - 1) (dataConIdentity name)
+lfClosureType (LFThunk lft) = thunkClosureType (lft_sfi lft)
+lfClosureType _ = panic "lfClosureType"
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk off) = ThunkSelector off
@@ -340,22 +334,23 @@ thunkClosureType _ = Thunk
-- nodeMustPointToIt
-----------------------------------------------------------------------------
-nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
+nodeMustPointToIt :: DynFlags -> LambdaFormInfo a -> Bool
-- If nodeMustPointToIt is true, then the entry convention for
-- this closure has R1 (the "Node" register) pointing to the
-- closure itself --- the "self" argument
-nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
- = not no_fvs -- Certainly if it has fvs we need to point to it
- || isNotTopLevel top -- See Note [GC recovery]
+nodeMustPointToIt _ (LFReEntrant lfr)
+ = not (lfr_no_fvs lfr) -- Certainly if it has fvs we need to point to it
+ || isNotTopLevel (lfr_top_lvl lfr) -- See Note [GC recovery]
-- For lex_profiling we also access the cost centre for a
-- non-inherited (i.e. non-top-level) function.
-- The isNotTopLevel test above ensures this is ok.
-nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
- = not no_fvs -- Self parameter
- || isNotTopLevel top -- Note [GC recovery]
- || updatable -- Need to push update frame
+nodeMustPointToIt dflags (LFThunk lft)
+ | NonStandardThunk <- lft_sfi lft
+ = not (lft_no_fvs lft) -- Self parameter
+ || isNotTopLevel (lft_top_lvl lft) -- Note [GC recovery]
+ || lft_updatable lft -- Need to push update frame
|| gopt Opt_SccProfilingOn dflags
-- For the non-updatable (single-entry case):
--
@@ -369,7 +364,7 @@ nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk
= True
-nodeMustPointToIt _ (LFCon _) = True
+nodeMustPointToIt _ (LFCon _ _) = True
-- Strictly speaking, the above two don't need Node to point
-- to it if the arity = 0. But this is a *really* unlikely
@@ -456,7 +451,8 @@ getCallMethod :: DynFlags
-> Id -- Function Id used to chech if it can refer to
-- CAF's and whether the function is tail-calling
-- itself
- -> LambdaFormInfo -- Its info
+ -> LambdaFormInfo a
+ -- Its info
-> RepArity -- Number of available arguments
-> RepArity -- Number of them being void arguments
-> CgLoc -- Passed in from cgIdApp so that we can
@@ -480,31 +476,30 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc
-- self-recursive tail calls] in GHC.StgToCmm.Expr for more details
= JumpToIt block_id args
-getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+getCallMethod dflags name id (LFReEntrant lfr) n_args _v_args _cg_loc
_self_loop_info
| n_args == 0 -- No args at all
&& not (gopt Opt_SccProfilingOn dflags)
-- See Note [Evaluating functions with profiling] in rts/Apply.cmm
- = ASSERT( arity /= 0 ) ReturnIt
- | n_args < arity = SlowCall -- Not enough args
- | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
+ = ASSERT( lfr_rep_arity lfr /= 0 ) ReturnIt
+ | n_args < lfr_rep_arity lfr = SlowCall -- Not enough args
+ | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) (lfr_rep_arity lfr)
getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
= ASSERT( n_args == 0 ) ReturnIt
-getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
+getCallMethod _ _name _ (LFCon _ _) n_args _v_args _cg_loc _self_loop_info
= ASSERT( n_args == 0 ) ReturnIt
-- n_args=0 because it'd be ill-typed to apply a saturated
-- constructor application to anything
-getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
- n_args _v_args _cg_loc _self_loop_info
- | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
- = SlowCall -- We cannot just enter it [in eval/apply, the entry code
- -- is the fast-entry code]
+getCallMethod dflags name id (LFThunk lft) n_args _v_args _cg_loc _self_loop_info
+ | lft_mb_fun lft -- it *might* be a function, so we must "call" it (which is always safe)
+ = SlowCall -- We cannot just enter it [in eval/apply, the entry code
+ -- is the fast-entry code]
-- Since is_fun is False, we are *definitely* looking at a data value
- | updatable || gopt Opt_Ticky dflags -- to catch double entry
+ | lft_updatable lft || gopt Opt_Ticky dflags -- to catch double entry
{- OLD: || opt_SMP
I decided to remove this, because in SMP mode it doesn't matter
if we enter the same thunk multiple times, so the optimisation
@@ -514,7 +509,7 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
-- even a non-updatable selector thunk can be updated by the garbage
-- collector, so we must enter it. (#8817)
- | SelectorThunk{} <- std_form_info
+ | SelectorThunk{} <- lft_sfi lft
= EnterIt
-- We used to have ASSERT( n_args == 0 ), but actually it is
@@ -526,8 +521,7 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
| otherwise -- Jump direct to code for single-entry thunks
= ASSERT( n_args == 0 )
- DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
- updatable) 0
+ DirectEntry (thunkEntryLabel dflags name (idCafInfo id) (lft_sfi lft) (lft_updatable lft)) 0
getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
= SlowCall -- might be a function
@@ -570,7 +564,7 @@ data ClosureInfo
-- code for ticky and profiling, and we could pass the information
-- around separately, but it doesn't do much harm to keep it here.
- closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
+ closureLFInfo :: !LocalLFI, -- NOTE: not an LFCon
-- this tells us about what the closure contains: it's right-hand-side.
-- the rest is just an unpacked CmmInfoTable.
@@ -595,10 +589,10 @@ mkCmmInfo ClosureInfo {..} id ccs
--------------------------------------
mkClosureInfo :: DynFlags
- -> Bool -- Is static
+ -> Bool -- Is static
-> Id
- -> LambdaFormInfo
- -> Int -> Int -- Total and pointer words
+ -> LocalLFI
+ -> Int -> Int -- Total and pointer words
-> String -- String descriptor
-> ClosureInfo
mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
@@ -643,9 +637,9 @@ blackHoleOnEntry cl_info
| otherwise
= case closureLFInfo cl_info of
- LFReEntrant {} -> False
- LFLetNoEscape -> False
- LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks]
+ LFReEntrant {} -> False
+ LFLetNoEscape -> False
+ LFThunk lft -> lft_updatable lft -- See Note [Black-holing non-updatable thunks]
_other -> panic "blackHoleOnEntry"
{- Note [Black-holing non-updatable thunks]
@@ -721,13 +715,13 @@ isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
-lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _) = upd
+lfUpdatable :: LambdaFormInfo a -> Bool
+lfUpdatable (LFThunk lft) = lft_updatable lft
lfUpdatable _ = False
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
-closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk lft }) = not (lft_updatable lft)
+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant (LFR_Local _ OneShotLam _ _ _) }) = True
closureSingleEntry _ = False
closureReEntrant :: ClosureInfo -> Bool
@@ -737,21 +731,14 @@ closureReEntrant _ = False
closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
-lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
-lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc)
-lfFunInfo _ = Nothing
+lfFunInfo :: LocalLFI -> Maybe (RepArity, ArgDescr)
+lfFunInfo (LFReEntrant lfr) = Just (lfr_rep_arity lfr, lfr_arg_descr lfr)
+lfFunInfo _ = Nothing
funTag :: DynFlags -> ClosureInfo -> DynTag
funTag dflags (ClosureInfo { closureLFInfo = lf_info })
= lfDynTag dflags lf_info
-isToplevClosure :: ClosureInfo -> Bool
-isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
- = case lf_info of
- LFReEntrant TopLevel _ _ _ _ -> True
- LFThunk TopLevel _ _ _ _ -> True
- _other -> False
-
--------------------------------------
-- Label generation
--------------------------------------
@@ -767,14 +754,14 @@ closureLocalEntryLabel dflags
| tablesNextToCode dflags = toInfoLbl . closureInfoLabel
| otherwise = toEntryLbl . closureInfoLabel
-mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
+mkClosureInfoTableLabel :: Id -> LocalLFI -> CLabel
mkClosureInfoTableLabel id lf_info
= case lf_info of
- LFThunk _ _ upd_flag (SelectorThunk offset) _
- -> mkSelectorInfoLabel upd_flag offset
+ LFThunk lft | SelectorThunk offset <- lft_sfi lft
+ -> mkSelectorInfoLabel (lft_updatable lft) offset
- LFThunk _ _ upd_flag (ApThunk arity) _
- -> mkApInfoTableLabel upd_flag arity
+ LFThunk lft | ApThunk arity <- lft_sfi lft
+ -> mkApInfoTableLabel (lft_updatable lft) arity
LFThunk{} -> std_mk_lbl name cafs
LFReEntrant{} -> std_mk_lbl name cafs
@@ -878,7 +865,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
name = dataConName data_con
info_lbl = mkConInfoTableLabel name NoCafRefs
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
- cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
+ cl_type = Constr (dataConTagZ data_con) (dataConIdentity (dataConName data_con))
-- We keep the *zero-indexed* tag in the srt_len field
-- of the info table of a data constructor.
=====================================
compiler/GHC/StgToCmm/Env.hs
=====================================
@@ -50,18 +50,17 @@ import UniqFM
import Util
import VarEnv
import GHC.Core.DataCon
-import BasicTypes
-------------------------------------
-- Manipulating CgIdInfo
-------------------------------------
-mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
+mkCgIdInfo :: Id -> LambdaFormInfo a -> CmmExpr -> CgIdInfo
mkCgIdInfo id lf expr
= CgIdInfo { cg_id = id, cg_lf = lf
, cg_loc = CmmLoc expr }
-litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
+litIdInfo :: DynFlags -> Id -> LambdaFormInfo a -> CmmLit -> CgIdInfo
litIdInfo dflags id lf lit
= CgIdInfo { cg_id = id, cg_lf = lf
, cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }
@@ -78,13 +77,13 @@ lneIdInfo platform id regs
blk_id = mkBlockId (idUnique id)
-rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
+rhsIdInfo :: Id -> LocalLFI -> FCode (CgIdInfo, LocalReg)
rhsIdInfo id lf_info
= do platform <- getPlatform
reg <- newTemp (gcWord platform)
return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
-mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
+mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo a -> CmmExpr -> CmmAGraph
mkRhsInit dflags reg lf_info expr
= mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info))
where platform = targetPlatform dflags
@@ -149,7 +148,7 @@ getCgIdInfo id
cgLookupPanic id -- Bug
}}}
-mkLFImported :: Id -> LambdaFormInfo
+mkLFImported :: Id -> ImportedLFI
mkLFImported id =
case idLFInfo_maybe id of
Just lf_info ->
@@ -157,12 +156,13 @@ mkLFImported id =
Nothing
| Just con <- isDataConWorkId_maybe id
, isNullaryRepDataCon con
- -> LFCon con -- An imported nullary constructor
+ -> LFCon (dataConName con) (dataConTag con)
+ -- An imported nullary constructor
-- We assume that the constructor is evaluated so that
-- the id really does point directly to the constructor
| arity > 0
- -> LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+ -> LFReEntrant (LFR_Imported arity)
| otherwise
-> mkLFArgument id -- Not sure of exact arity
@@ -200,7 +200,7 @@ getNonVoidArgAmodes (arg:args)
-- Interface functions for binding and re-binding names
------------------------------------------------------------------------
-bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: NonVoid Id -> LambdaFormInfo a -> FCode LocalReg
-- Bind an Id to a fresh LocalReg
bindToReg nvid@(NonVoid id) lf_info
= do platform <- getPlatform
@@ -212,8 +212,8 @@ rebindToReg :: NonVoid Id -> FCode LocalReg
-- Like bindToReg, but the Id is already in scope, so
-- get its LF info from the envt
rebindToReg nvid@(NonVoid id)
- = do { info <- getCgIdInfo id
- ; bindToReg nvid (cg_lf info) }
+ = do { CgIdInfo _ lfi _ <- getCgIdInfo id
+ ; bindToReg nvid lfi }
bindArgToReg :: NonVoid Id -> FCode LocalReg
bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -861,13 +861,14 @@ cgIdApp fun_id args = do
dflags <- getDynFlags
fun_info <- getCgIdInfo fun_id
self_loop_info <- getSelfLoop
+ case fun_info of
+ { CgIdInfo _ lf_info _ ->
let fun_arg = StgVarArg fun_id
fun_name = idName fun_id
fun = idInfoToAmode fun_info
- lf_info = cg_lf fun_info
n_args = length args
v_args = length $ filter (isVoidTy . stgArgType) args
- node_points dflags = nodeMustPointToIt dflags lf_info
+ node_points dflags = nodeMustPointToIt dflags lf_info in
case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of
-- A value in WHNF, so we can just return it.
ReturnIt
@@ -896,7 +897,7 @@ cgIdApp fun_id args = do
; cmm_args <- getNonVoidArgAmodes args
; emitMultiAssign lne_regs cmm_args
; emit (mkBranch blk_id)
- ; return AssignedDirectly }
+ ; return AssignedDirectly } }
-- Note [Self-recursive tail calls]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.StgToCmm.Heap (
mkStaticClosureFields, mkStaticClosure,
- allocDynClosure, allocDynClosureCmm, allocHeapClosure,
+ allocDynClosure, allocHeapClosure,
emitSetDynHdr
) where
@@ -33,6 +33,7 @@ import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Env
+import GHC.StgToCmm.Types
import GHC.Cmm.Graph
@@ -60,7 +61,7 @@ import Data.Maybe (isJust)
allocDynClosure
:: Maybe Id
-> CmmInfoTable
- -> LambdaFormInfo
+ -> LocalLFI
-> CmmExpr -- Cost Centre to stick in the object
-> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
@@ -71,7 +72,11 @@ allocDynClosure
-> FCode CmmExpr -- returns Hp+n
allocDynClosureCmm
- :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+ :: Maybe Id
+ -> CmmInfoTable
+ -> LocalLFI
+ -> CmmExpr
+ -> CmmExpr
-> [(CmmExpr, ByteOff)]
-> FCode CmmExpr -- returns Hp+n
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -595,7 +595,7 @@ stdPattern reps
emitClosureProcAndInfoTable :: Bool -- top-level?
-> Id -- name of the closure
- -> LambdaFormInfo
+ -> LambdaFormInfo a
-> CmmInfoTable
-> [NonVoid Id] -- incoming arguments
-> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
--
@@ -64,6 +65,7 @@ import GhcPrelude hiding( sequence, succ )
import GHC.Platform
import GHC.Cmm
import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Types
import GHC.Driver.Session
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Graph as CmmGraph
@@ -172,15 +174,15 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
- = CgIdInfo
+ = forall a . CgIdInfo
{ cg_id :: Id -- Id that this is the info for
- , cg_lf :: LambdaFormInfo
- , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
+ , cg_lf :: LambdaFormInfo a -- LFI, local or imported
+ , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
}
instance Outputable CgIdInfo where
- ppr (CgIdInfo { cg_id = id, cg_loc = loc })
- = ppr id <+> text "-->" <+> ppr loc
+ ppr (CgIdInfo { cg_id = id, cg_loc = loc, cg_lf = lf })
+ = ppr id <+> text "-->" <+> ppr loc <+> parens (ppr lf)
-- Sequel tells what to do with the result of this expression
data Sequel
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -409,7 +409,7 @@ tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
-- Tick for the call pattern at slow call site (i.e. in addition to
-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
-tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
+tickySlowCall :: LambdaFormInfo a -> [StgArg] -> FCode ()
tickySlowCall _ [] = return ()
tickySlowCall lf_info args = do
-- see Note [Ticky for slow calls]
@@ -448,7 +448,7 @@ bad for both space and time).
-- -----------------------------------------------------------------------------
-- Ticky allocation
-tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo a -> FCode ()
-- Called when doing a dynamic heap allocation; the LambdaFormInfo
-- used to distinguish between closure types
--
=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -1,9 +1,19 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DataKinds, GADTs, KindSignatures, LambdaCase #-}
module GHC.StgToCmm.Types
( WordOff
- , LambdaFormInfo (..)
+
+ -- * LambdaFormInfo types
+ , LFIVariant (..), ImportedLFI, LocalLFI, LambdaFormInfo (..)
+ , LFReEntrant (..), LFThunk (..)
, ModuleLFInfos
+
+ -- * LambdaFormInfo queries
+ , lfr_top_lvl, lfr_one_shot, lfr_rep_arity, lfr_no_fvs, lfr_arg_descr
+ , lft_top_lvl, lft_no_fvs, lft_updatable, lft_sfi, lft_mb_fun
+
+ -- * Other stuff
+ , toImportedLFI
, Liveness
, ArgDescr (..)
, StandardFormInfo (..)
@@ -14,9 +24,9 @@ module GHC.StgToCmm.Types
import GhcPrelude
import BasicTypes
-import GHC.Core.DataCon
import NameEnv
import Outputable
+import Name
-- | Word offset, or word count
type WordOff = Int
@@ -25,31 +35,148 @@ type WordOff = Int
-- LambdaFormInfo
--------------------------------------------------------------------------------
--- | Maps names in the current module to their LambdaFormInfos
-type ModuleLFInfos = NameEnv LambdaFormInfo
+-- | Type alias for LambdaFormInfos of imported things
+type ImportedLFI = LambdaFormInfo 'LFI_Imported
--- Information about an identifier, from the code generator's point of view.
--- Every identifier is bound to a LambdaFormInfo in the environment, which gives
--- the code generator enough info to be able to tail call or return that
--- identifier.
+-- | Type alias for LambdaForInfos of local things
+type LocalLFI = LambdaFormInfo 'LFI_Local
+
+-- | Maps names in the current module to their exported LambdaFormInfos
+type ModuleLFInfos = NameEnv ImportedLFI
+
+-- | LambdaFormInfo variants
+data LFIVariant
+ = LFI_Imported
+ | LFI_Local
+
+-- | LambdaFormInfo for a re-entrant closure (a function)
+data LFReEntrant lfi_variant where
+ LFR_Imported
+ :: !RepArity
+ -> LFReEntrant 'LFI_Imported
+
+ LFR_Local
+ :: !TopLevelFlag
+ -> !OneShotInfo
+ -> !RepArity
+ -> !Bool
+ -- ^ True <=> no fvs
+ -> !ArgDescr
+ -> LFReEntrant 'LFI_Local
+
+-- | Lambda form info for a thunk (zero arity)
+data LFThunk lfi_variant where
+ LFT_Imported
+ :: !Bool
+ -- ^ True <=> updatable (i.e., *not* single-entry)
+ -> !StandardFormInfo
+ -> !Bool
+ -- ^ True <=> *might* be a function type
+ -> LFThunk 'LFI_Imported
+
+ LFT_Local
+ :: !TopLevelFlag
+ -> !Bool
+ -- ^ True <=> no fvs
+ -> !Bool
+ -- ^ True <=> updatable (i.e., *not* single-entry)
+ -> !StandardFormInfo
+ -> !Bool
+ -- ^ True <=> *might* be a function type
+ -> LFThunk 'LFI_Local
+
+--------------------------------------------------------------------------------
+-- LambdaFormInfo queries
+--------------------------------------------------------------------------------
+
+lfr_top_lvl :: LFReEntrant a -> TopLevelFlag
+lfr_top_lvl = \case
+ LFR_Imported _ -> TopLevel
+ LFR_Local top_lvl _ _ _ _ -> top_lvl
+
+lfr_one_shot :: LFReEntrant 'LFI_Local -> OneShotInfo
+lfr_one_shot (LFR_Local _ one_shot _ _ _) = one_shot
+
+lfr_rep_arity :: LFReEntrant a -> RepArity
+lfr_rep_arity = \case
+ LFR_Imported arity -> arity
+ LFR_Local _ _ arity _ _ -> arity
+
+lfr_no_fvs :: LFReEntrant a -> Bool
+lfr_no_fvs = \case
+ LFR_Imported _ -> True
+ LFR_Local _ _ _ no_fvs _ -> no_fvs
+
+lfr_arg_descr :: LFReEntrant 'LFI_Local -> ArgDescr
+lfr_arg_descr (LFR_Local _ _ _ _ arg_descr) = arg_descr
+
+lft_top_lvl :: LFThunk a -> TopLevelFlag
+lft_top_lvl = \case
+ LFT_Imported _ _ _ -> TopLevel
+ LFT_Local top_lvl _ _ _ _ -> top_lvl
+
+lft_no_fvs :: LFThunk a -> Bool
+lft_no_fvs = \case
+ LFT_Imported _ _ _ -> True
+ LFT_Local _ no_fvs _ _ _ -> no_fvs
+
+lft_updatable :: LFThunk a -> Bool
+lft_updatable = \case
+ LFT_Imported updatable _ _ -> updatable
+ LFT_Local _ _ updatable _ _ -> updatable
-data LambdaFormInfo
+lft_sfi :: LFThunk a -> StandardFormInfo
+lft_sfi = \case
+ LFT_Imported _ sfi _ -> sfi
+ LFT_Local _ _ _ sfi _ -> sfi
+
+lft_mb_fun :: LFThunk a -> Bool
+lft_mb_fun = \case
+ LFT_Imported _ _ mb_fun -> mb_fun
+ LFT_Local _ _ _ _ mb_fun -> mb_fun
+
+--------------------------------------------------------------------------------
+-- Local LFI to imported LFI
+--------------------------------------------------------------------------------
+
+toImportedLFI :: LambdaFormInfo a -> ImportedLFI
+toImportedLFI = \case
+ LFReEntrant lfr -> LFReEntrant (toImportedLFR lfr)
+ LFThunk lft -> LFThunk (toImportedLFT lft)
+ LFCon name tag -> LFCon name tag
+ LFUnknown mb_fun -> LFUnknown mb_fun
+ LFUnlifted -> LFUnlifted
+ LFLetNoEscape -> LFLetNoEscape -- TODO: This case should be unreachable
+
+toImportedLFR :: LFReEntrant a -> LFReEntrant 'LFI_Imported
+toImportedLFR = \case
+ LFR_Imported arity -> LFR_Imported arity
+ LFR_Local _ _ arity _ _ -> LFR_Imported arity
+
+toImportedLFT :: LFThunk a -> LFThunk 'LFI_Imported
+toImportedLFT = \case
+ LFT_Imported updatable sfi mb_fun -> LFT_Imported updatable sfi mb_fun
+ LFT_Local _ _ updatable sfi mb_fun -> LFT_Imported updatable sfi mb_fun
+
+--------------------------------------------------------------------------------
+
+-- | Information about an identifier, from the code generator's point of view.
+--
+-- Local identifiers are bound to a LambdaFormInfo in the environment, which
+-- gives the code generator enough info to be able to tail call or return that
+-- identifier.
+--
+-- Imported identifiers have the information in idLFInfo field.
+data LambdaFormInfo (lfi_variant :: LFIVariant)
= LFReEntrant -- Reentrant closure (a function)
- TopLevelFlag -- True if top level
- OneShotInfo
- !RepArity -- Arity. Invariant: always > 0
- !Bool -- True <=> no fvs
- ArgDescr -- Argument descriptor (should really be in ClosureInfo)
+ !(LFReEntrant lfi_variant)
| LFThunk -- Thunk (zero arity)
- TopLevelFlag
- !Bool -- True <=> no free vars
- !Bool -- True <=> updatable (i.e., *not* single-entry)
- StandardFormInfo
- !Bool -- True <=> *might* be a function type
+ !(LFThunk lfi_variant)
| LFCon -- A saturated constructor application
- DataCon -- The constructor
+ !Name -- Name of the constructor
+ !ConTag -- The constructor's (1-based) tag
| LFUnknown -- Used for function arguments and imported things.
-- We know nothing about this closure.
@@ -65,18 +192,40 @@ data LambdaFormInfo
| LFUnlifted -- A value of unboxed type;
-- always a value, needs evaluation
+ -- TODO: This should only be available for local LFIs
| LFLetNoEscape -- See LetNoEscape module for precise description
-instance Outputable LambdaFormInfo where
- ppr (LFReEntrant top oneshot rep fvs argdesc) =
- text "LFReEntrant" <> brackets (ppr top <+> ppr oneshot <+>
- ppr rep <+> pprFvs fvs <+> ppr argdesc)
- ppr (LFThunk top hasfv updateable sfi m_function) =
- text "LFThunk" <> brackets (ppr top <+> pprFvs hasfv <+> pprUpdateable updateable <+>
- ppr sfi <+> pprFuncFlag m_function)
- ppr (LFCon con) = text "LFCon" <> brackets (ppr con)
- ppr (LFUnknown m_func) =
- text "LFUnknown" <> brackets (pprFuncFlag m_func)
+instance Outputable (LFReEntrant a) where
+ ppr (LFR_Imported arity ) =
+ text "LFReEntrant" <> brackets (ppr arity)
+
+ ppr (LFR_Local top one_shot arity no_fvs arg_desc) =
+ text "LFReEntrant" <> brackets
+ (ppr top <+> ppr one_shot <+>
+ ppr arity <+> pprFvs no_fvs <+> ppr arg_desc)
+
+instance Outputable (LFThunk a) where
+ ppr (LFT_Imported updatable sfi mb_fun) =
+ text "LFThunk" <> brackets (hcat
+ [ text "upd=" <> ppr updatable
+ , text "sfi=" <> ppr sfi
+ , text "mb_fun=" <> ppr mb_fun
+ ])
+
+ ppr (LFT_Local top no_fvs updatable sfi mb_fun) =
+ text "LFThunk" <> brackets (hcat
+ [ text "top_lvl=" <> ppr top
+ , text "no_fvs=" <> ppr no_fvs
+ , text "updatable=" <> ppr updatable
+ , text "sfi=" <> ppr sfi
+ , text "mb_fun=" <> ppr mb_fun
+ ])
+
+instance Outputable (LambdaFormInfo a) where
+ ppr (LFReEntrant lfr) = ppr lfr
+ ppr (LFThunk lft) = ppr lft
+ ppr (LFCon name _tag) = text "LFCon" <> brackets (ppr name)
+ ppr (LFUnknown mb_fun) = text "LFUnknown" <> brackets (pprFuncFlag mb_fun)
ppr LFUnlifted = text "LFUnlifted"
ppr LFLetNoEscape = text "LFLetNoEscape"
@@ -88,10 +237,6 @@ pprFuncFlag :: Bool -> SDoc
pprFuncFlag True = text "mFunc"
pprFuncFlag False = text "value"
-pprUpdateable :: Bool -> SDoc
-pprUpdateable True = text "updateable"
-pprUpdateable False = text "oneshot"
-
--------------------------------------------------------------------------------
-- | We represent liveness bitmaps as a Bitmap (whose internal representation
@@ -114,16 +259,11 @@ data ArgDescr
| ArgGen -- General case
Liveness -- Details about the arguments
-
- | ArgUnknown -- For imported binds.
- -- Invariant: Never Unknown for binds of the module
- -- we are compiling.
deriving (Eq)
instance Outputable ArgDescr where
ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
- ppr ArgUnknown = text "ArgUnknown"
--------------------------------------------------------------------------------
-- | StandardFormInfo tells whether this thunk has one of a small number of
=====================================
compiler/basicTypes/Id.hs
=====================================
@@ -734,15 +734,15 @@ setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
---------------------------------
-- Lambda form info
-idLFInfo :: HasCallStack => Id -> LambdaFormInfo
+idLFInfo :: HasCallStack => Id -> ImportedLFI
idLFInfo id = case lfInfo (idInfo id) of
Nothing -> pprPanic "idLFInfo" (text "LFInfo not available for Id" <+> ppr id)
- Just lf_info -> lf_info
+ Just lfi -> lfi
-idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
+idLFInfo_maybe :: Id -> Maybe ImportedLFI
idLFInfo_maybe = lfInfo . idInfo
-setIdLFInfo :: Id -> LambdaFormInfo -> Id
+setIdLFInfo :: Id -> ImportedLFI -> Id
setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id
---------------------------------
=====================================
compiler/basicTypes/IdInfo.hs
=====================================
@@ -75,7 +75,7 @@ module IdInfo (
cafInfo, setCafInfo,
-- ** The LambdaFormInfo type
- LambdaFormInfo(..),
+ LambdaFormInfo(..), ImportedLFI,
lfInfo, setLFInfo,
-- ** Tick-box Info
@@ -108,7 +108,7 @@ import Demand
import Cpr
import Util
-import GHC.StgToCmm.Types (LambdaFormInfo (..))
+import GHC.StgToCmm.Types (LambdaFormInfo (..), ImportedLFI)
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setRuleInfo`,
@@ -278,7 +278,11 @@ data IdInfo
-- n <=> all calls have at least n arguments
levityInfo :: LevityInfo,
-- ^ when applied, will this Id ever have a levity-polymorphic type?
- lfInfo :: !(Maybe LambdaFormInfo)
+ lfInfo :: !(Maybe ImportedLFI)
+ -- ^ Lambda form info of the Id. Not available in two cases:
+ --
+ -- 1. The Id is wired-in and we haven't given it an LFI
+ -- 2. The Id is local to the module being compiled
}
-- Setters
@@ -308,7 +312,7 @@ setCallArityInfo info ar = info { callArityInfo = ar }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo info caf = info { cafInfo = caf }
-setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
+setLFInfo :: IdInfo -> ImportedLFI -> IdInfo
setLFInfo info lf = info { lfInfo = Just lf }
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
=====================================
compiler/main/UpdateCafInfos.hs
=====================================
@@ -17,7 +17,7 @@ import NameSet
import Util
import Var
import Outputable
-import GHC.StgToCmm.Types (ModuleLFInfos)
+import GHC.StgToCmm.Types (ModuleLFInfos, toImportedLFI)
#include "HsVersions.h"
@@ -106,7 +106,7 @@ updateIdCafInfo non_cafs lf_infos id =
id1 = if not_caffy then setIdCafInfo id NoCafRefs else id
id2 = case mb_lf_info of
Nothing -> id1
- Just lf_info -> setIdLFInfo id1 lf_info
+ Just lf_info -> setIdLFInfo id1 (toImportedLFI lf_info)
in
id2
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -64,7 +64,7 @@ T17648:
# NoCafRefs) to the interface files.
'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O T17648.hs -v0
'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n' | \
- grep -F 'f :: T GHC.Types.Int -> () [HasNoCafRefs, LambdaFormInfo' >/dev/null
+ grep -F 'f :: T GHC.Types.Int -> () [HasNoCafRefs, LambdaFormInfo' >/dev/null
# Second compilation with -fcatch-bottoms, f should be CAFFY
'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O \
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -102,7 +102,7 @@ T4201:
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T4201.hs
'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T4201.hi > T4201.list
# poor man idea about how to replace GNU grep -B2 "Sym" invocation with pure POSIX tools
- for i in `grep -n "Sym" T4201.list | cut -d ':' -f -1`; do head -$$i T4201.list | tail -5; done
+ for i in `grep -n "Sym" T4201.list | cut -d ':' -f -1`; do head -$$i T4201.list | tail -4; done
$(RM) -f T4201.list
# This one looped as a result of bogus specialisation
=====================================
testsuite/tests/simplCore/should_compile/T4201.stdout
=====================================
@@ -1,5 +1,4 @@
- [HasNoCafRefs,
- LambdaFormInfo: LFReEntrant (NoOneShotInfo, 1, True), Arity: 1,
+ [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, Arity: 1,
Strictness: <S,1*H>, CPR: m1,
Unfolding: InlineRule (0, True, True)
bof `cast` (Sym (N:Foo[0]) ->_R <T>_R)]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/168a1ebb1793513203f81af92dd6d023c20dd996
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/168a1ebb1793513203f81af92dd6d023c20dd996
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200324/f3d359c9/attachment-0001.html>
More information about the ghc-commits
mailing list