diff options
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 19 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 20 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 51 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 15 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 22 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 26 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 30 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmTicky.hs | 3 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeItbls.hs | 18 | ||||
| -rw-r--r-- | compiler/simplStg/UnariseStg.hs | 14 |
10 files changed, 138 insertions, 80 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 85f8845c8a..28ca97d9a2 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -138,7 +138,9 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) -- It's already been externalised if necessary cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) - = cgTopRhsCon dflags bndr con args + = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables @@ -219,8 +221,8 @@ cgDataCon data_con = do { dflags <- getDynFlags ; let (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - arg_things) = mkVirtConstrOffsets dflags arg_reps + ptr_wds) -- #ptr_wds + = mkVirtConstrSizes dflags arg_reps nonptr_wds = tot_wds - ptr_wds @@ -240,14 +242,17 @@ cgDataCon data_con -- NB 2: We don't set CC when entering data (WDP 94/06) do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) - ; tickyReturnOldCon (length arg_things) + ; tickyReturnOldCon (length arg_reps) ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, UnaryType)] - arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con - , rep_ty <- repTypeArgs ty] + -- We're generating info tables, so we don't know and care about + -- what the actual arguments are. Using () here as the place holder. + arg_reps :: [NonVoid PrimRep] + arg_reps = [NonVoid (typePrimRep rep_ty) | ty <- dataConRepArgTys data_con + , rep_ty <- repTypeArgs ty + , not (isVoidTy rep_ty)] -- Dynamic closure code for non-nullary constructors only ; when (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 93756ec406..e173f354b7 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -206,7 +206,9 @@ cgRhs :: Id cgRhs id (StgRhsCon cc con args) = withNewTickyCounterCon (idName id) $ - buildDynCon id True cc con args + buildDynCon id True cc con (assertNonVoidStgArgs args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} cgRhs id (StgRhsClosure cc bi fvs upd_flag args body) @@ -273,8 +275,9 @@ mkRhsClosure dflags bndr _cc _bi , StgApp selectee [{-no args-}] <- strip sel_expr , the_fv == scrutinee -- Scrutinee is the only free variable - , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params) - -- Just want the layout + , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params)) + -- pattern binders are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) , let offset_into_int = bytesToWordsRoundUp dflags the_offset @@ -305,7 +308,7 @@ mkRhsClosure dflags bndr _cc _bi -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . unsafe_stripNV) fvs + , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= mAX_SPEC_AP_SIZE dflags , not (gopt Opt_SccProfilingOn dflags) @@ -348,7 +351,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body fv_details :: [(NonVoid Id, ByteOff)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps (map unsafe_stripNV reduced_fvs)) + (addIdReps reduced_fvs) closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -392,7 +395,8 @@ cgRhsStdThunk bndr lf_info payload mod_name <- getModuleName ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) + (addArgReps (nonVoidStgArgs payload)) descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo dflags False -- Not static @@ -421,9 +425,9 @@ mkClosureLFInfo :: DynFlags -> LambdaFormInfo mkClosureLFInfo dflags bndr top fvs upd_flag args | null args = - mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag + mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag | otherwise = - mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) + mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args) ------------------------------------------------------------------------ diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index f831789454..23b803cc56 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -18,6 +18,9 @@ module StgCmmClosure ( idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, argPrimRep, + NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, + assertNonVoidIds, assertNonVoidStgArgs, + -- * LambdaFormInfo LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... @@ -84,6 +87,8 @@ import Outputable import DynFlags import Util +import Data.Coerce (coerce) + ----------------------------------------------------------------------------- -- Data types and synonyms ----------------------------------------------------------------------------- @@ -115,6 +120,42 @@ isKnownFun LFLetNoEscape = True isKnownFun _ = False +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) + +fromNonVoid :: NonVoid a -> a +fromNonVoid (NonVoid a) = a + +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))] + +-- | Used in places where some invariant ensures that all these Ids are +-- non-void; e.g. constructor field binders in case expressions. +-- See Note [Post-unarisation invariants] in UnariseStg. +assertNonVoidIds :: [Id] -> [NonVoid Id] +assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids)) + coerce ids + +nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] +nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))] + +-- | Used in places where some invariant ensures that all these arguments are +-- non-void; e.g. constructor arguments. +-- See Note [Post-unarisation invariants] in UnariseStg. +assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] +assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args)) + coerce args + + ----------------------------------------------------------------------------- -- Representations ----------------------------------------------------------------------------- @@ -126,11 +167,13 @@ idPrimRep id = typePrimRep (idType id) -- NB: typePrimRep fails on unboxed tuples, -- but by StgCmm no Ids have unboxed tuple type -addIdReps :: [Id] -> [(PrimRep, Id)] -addIdReps ids = [(idPrimRep id, id) | id <- ids] +addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] +addIdReps = map (\id -> let id' = fromNonVoid id + in NonVoid (idPrimRep id', id')) -addArgReps :: [StgArg] -> [(PrimRep, StgArg)] -addArgReps args = [(argPrimRep arg, arg) | arg <- args] +addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] +addArgReps = map (\arg -> let arg' = fromNonVoid arg + in NonVoid (argPrimRep arg', arg')) argPrimRep :: StgArg -> PrimRep argPrimRep arg = typePrimRep (stgArgType arg) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 4255f10201..3a615f750f 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -58,7 +58,7 @@ import Data.Char cgTopRhsCon :: DynFlags -> Id -- Name of thing bound to this RHS -> DataCon -- Id - -> [StgArg] -- Args + -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) cgTopRhsCon dflags id con args = let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) @@ -72,7 +72,7 @@ cgTopRhsCon dflags id con args = do { this_mod <- getModuleName ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. - ASSERT( not (isDllConApp dflags this_mod con args) ) return () + MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) ) ; ASSERT( args `lengthIs` countConRepArgs con ) return () -- LAY IT OUT @@ -120,7 +120,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor - -> [StgArg] -- Its args + -> [NonVoid StgArg] -- Its args -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code buildDynCon binder actually_bound cc con args @@ -133,7 +133,7 @@ buildDynCon' :: DynFlags -> Id -> Bool -> CostCentreStack -> DataCon - -> [StgArg] + -> [NonVoid StgArg] -> FCode (CgIdInfo, FCode CmmAGraph) {- We used to pass a boolean indicating whether all the @@ -192,7 +192,7 @@ because they don't support cross package data references well. buildDynCon' dflags platform binder _ _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) - , StgLitArg (MachInt val) <- arg + , NonVoid (StgLitArg (MachInt val)) <- arg , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... = do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE") @@ -206,7 +206,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] buildDynCon' dflags platform binder _ _cc con [arg] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) - , StgLitArg (MachChar val) <- arg + , NonVoid (StgLitArg (MachChar val)) <- arg , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags @@ -228,7 +228,6 @@ buildDynCon' dflags _ binder actually_bound ccs con args gen_code reg = do { let (tot_wds, ptr_wds, args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) - -- No void args in args_w_offsets nonptr_wds = tot_wds - ptr_wds info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds @@ -250,7 +249,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args -- Binding constructor arguments --------------------------------------------------------------- -bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg] +bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg] -- bindConArgs is called from cgAlt of a case -- (bindConArgs con args) augments the environment with bindings for the -- binders args, assuming that we have just returned from a 'case' which diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 44d3df84ee..30307a2a3a 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -13,8 +13,6 @@ module StgCmmEnv ( litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, idInfoToAmode, - NonVoid(..), unsafe_stripNV, nonVoidIds, - addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, @@ -30,6 +28,7 @@ import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure +import StgSyn (StgArg) import CLabel @@ -46,25 +45,6 @@ import UniqFM import VarEnv ------------------------------------- --- Non-void types -------------------------------------- --- We frequently need the invariant that an Id or a an argument --- is of a non-void type. This type is a witness to the invariant. - -newtype NonVoid a = NonVoid a - deriving (Eq, Show) - --- Use with care; if used inappropriately, it could break invariants. -unsafe_stripNV :: NonVoid a -> a -unsafe_stripNV (NonVoid a) = a - -instance (Outputable a) => Outputable (NonVoid a) where - ppr (NonVoid a) = ppr a - -nonVoidIds :: [Id] -> [NonVoid Id] -nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] - -------------------------------------- -- Manipulating CgIdInfo ------------------------------------- diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 91cfba6bd0..fdd902d8c7 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -525,24 +525,24 @@ isSimpleOp (StgPrimCallOp _) _ = return False ----------------- chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] --- These are the binders of a case that are assigned --- by the evaluation of the scrutinee --- Only non-void ones come back +-- These are the binders of a case that are assigned by the evaluation of the +-- scrutinee. +-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg. chooseReturnBndrs bndr (PrimAlt _) _alts - = nonVoidIds [bndr] + = assertNonVoidIds [bndr] chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)] - = ASSERT2(n == length (nonVoidIds ids), ppr n $$ ppr ids $$ ppr _bndr) - nonVoidIds ids -- 'bndr' is not assigned! + = ASSERT2(n == length ids, ppr n $$ ppr ids $$ ppr _bndr) + assertNonVoidIds ids -- 'bndr' is not assigned! chooseReturnBndrs bndr (AlgAlt _) _alts - = nonVoidIds [bndr] -- Only 'bndr' is assigned + = assertNonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs bndr PolyAlt _alts - = nonVoidIds [bndr] -- Only 'bndr' is assigned + = assertNonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" - -- UbxTupALt has only one alternative + -- MultiValAlt has only one alternative ------------------------------------- cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt] @@ -651,7 +651,9 @@ cgAltRhss gc_plan bndr alts = do cg_alt (con, bndrs, rhs) = getCodeScoped $ maybeAltHeapCheck gc_plan $ - do { _ <- bindConArgs con base_reg bndrs + do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs) + -- alt binders are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg ; _ <- cgExpr rhs ; return con } forkAlts (map cg_alt alts) @@ -677,7 +679,9 @@ cgConApp con stg_args | otherwise -- Boxed constructors; allocate and return = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args ) do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False - currentCCS con stg_args + currentCCS con (assertNonVoidStgArgs stg_args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg -- The first "con" says that the name bound to this -- closure is is "con", which is a bit of a fudge, but -- it only affects profiling (hence the False) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 59bbc8d5ea..21698c7bbf 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,7 @@ module StgCmmLayout ( slowCall, directCall, - mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, + mkVirtHeapOffsets, mkVirtConstrOffsets, mkVirtConstrSizes, getHpRelOffset, ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ) where @@ -388,8 +388,8 @@ getHpRelOffset virtual_offset mkVirtHeapOffsets :: DynFlags - -> Bool -- True <=> is a thunk - -> [(PrimRep,a)] -- Things to make offsets for + -> Bool -- True <=> is a thunk + -> [NonVoid (PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* [(NonVoid a, ByteOff)]) @@ -398,14 +398,12 @@ mkVirtHeapOffsets -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER -- First in list gets lowest offset, which is initial offset + 1. -- --- Void arguments are removed, so output list may be shorter than --- input list --- -- mkVirtHeapOffsets always returns boxed things with smaller offsets -- than the unboxed things mkVirtHeapOffsets dflags is_thunk things - = ( bytesToWordsRoundUp dflags tot_bytes + = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) + ( bytesToWordsRoundUp dflags tot_bytes , bytesToWordsRoundUp dflags bytes_of_ptrs , ptrs_w_offsets ++ non_ptrs_w_offsets ) @@ -414,24 +412,34 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSizeW dflags hdr_bytes = wordsToBytes dflags hdr_words - non_void_things = filterOut (isVoidRep . fst) things - (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things + (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things (bytes_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs (tot_bytes, non_ptrs_w_offsets) = mapAccumL computeOffset bytes_of_ptrs non_ptrs - computeOffset bytes_so_far (rep, thing) + computeOffset bytes_so_far nv_thing = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)), (NonVoid thing, hdr_bytes + bytes_so_far)) + where (rep,thing) = fromNonVoid nv_thing -- | Just like mkVirtHeapOffsets, but for constructors mkVirtConstrOffsets - :: DynFlags -> [(PrimRep,a)] + :: DynFlags -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False +-- | Just like mkVirtConstrOffsets, but used when we don't have the actual +-- arguments. Useful when e.g. generating info tables; we just need to know +-- sizes of pointer and non-pointer fields. +mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes dflags field_reps + = (tot_wds, ptr_wds) + where + (tot_wds, ptr_wds, _) = + mkVirtConstrOffsets dflags + (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 8df2dcac28..8e4e5ece5a 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -107,7 +107,6 @@ module StgCmmTicky ( #include "HsVersions.h" import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString ) -import StgCmmEnv ( NonVoid, unsafe_stripNV ) import StgCmmClosure import StgCmmUtils import StgCmmMonad @@ -234,7 +233,7 @@ emitTickyCounter cloType name args else n <+> ext <+> p ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name - ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args + ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args ; emitDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter -- diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 8e30234c4f..4a4a03913d 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -16,10 +16,10 @@ import HscTypes import Name ( Name, getName ) import NameEnv import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import RepType ( typePrimRep, repTypeArgs ) -import StgCmmLayout ( mkVirtHeapOffsets ) -import StgCmmClosure ( tagForCon ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons, isVoidRep ) +import RepType +import StgCmmLayout ( mkVirtConstrSizes ) +import StgCmmClosure ( tagForCon, NonVoid (..) ) import Util import Panic @@ -54,12 +54,14 @@ make_constr_itbls hsc_env cons = mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ (typePrimRep rep_arg,rep_arg) + let rep_args = [ NonVoid prim_rep | arg <- dataConRepArgTys dcon - , rep_arg <- repTypeArgs arg ] + , slot_ty <- repTypeSlots (repType arg) + , let prim_rep = slotPrimRep slot_ty + , not (isVoidRep prim_rep) ] - (tot_wds, ptr_wds, _) = - mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args + (tot_wds, ptr_wds) = + mkVirtConstrSizes dflags rep_args ptrs' = ptr_wds nptrs' = tot_wds - ptr_wds diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 80848793fc..a393e8fae9 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -174,6 +174,20 @@ table for an Id may be larger than the idArity. Instead we record what we call the RepArity, which is the Arity taking into account any expanded arguments, and corresponds to the number of (possibly-void) *registers* arguments will arrive in. + +Note [Post-unarisation invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +STG programs after unarisation have these invariants: + + * No unboxed sums at all. + + * No unboxed tuple binders. Tuples only appear in return position. + + * DataCon applications (StgRhsCon and StgConApp) don't have void arguments. + This means that it's safe to wrap `StgArg`s of DataCon applications with + `StgCmmEnv.NonVoid`, for example. + + * Alt binders (binders in patterns) are always non-void. -} {-# LANGUAGE CPP, TupleSections #-} |