diff options
Diffstat (limited to 'compiler/GHC/Stg/Unarise.hs')
| -rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 390 |
1 files changed, 324 insertions, 66 deletions
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 35eb37b17f..c7d7ebcc6a 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -184,6 +184,129 @@ So we pass type arguments of the DataCon's TyCon in StgConApp to decide what layout to use. Note that unlifted values can't be let-bound, so we don't need types in StgRhsCon. +Note [Casting slot arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this function which selects between Int32# and Int64# from a unboxed sum. + + foo :: (# Int32# | Int64# #) -> FD + foo x = case x of + (# x1 | #) -> F x1 + (# | x2 #) -> D x2 + +Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep. +However we used to generate this (bogus) code after Unarise giving rise to #22208: + + M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD + [GblId, Arity=1, Unf=OtherCon []] = + {} \r [sum_tag sum_field] + case sum_tag of tag_gsc { + __DEFAULT -> M.F [sum_field]; + 2# -> M.D [sum_field]; + }; + +Where sum_field is used both as Int32# and Int64# depending on the branch +because they share the same SlotTy. +This usually works out since we put all int's in the same sort of register. +So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce +correct code in the most cases. +However there are cases where this goes wrong, causing lint errors,in the case of #22208 +compiler panics or in some cases incorrect results in the C backend. +For now our solution is to construct proper casts between the PrimRep of the slot and +the variables we want to store in, or read out of these slots. + +This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32 +we convert it to a Int64 on construction of the tuple value, and convert it back +to a Int32 once when want to use the field. On most backends these coversions should +be no-ops at runtime so this seems reasonable. + +Conversion for values coming out of a strict field happen in mapSumIdBinders. While +conversion during the construction of sums happen inside mkUbxSum. + +------------- A full example of casting during sum construction ---------------- + +To compile a constructor application of a unboxed sum of type (# Int32# | Int64# ) +in an expression like `let sum = (# x | #)` we will call mkUbxSum to determine +which binders we have to replace sum with at use sites during unarise. +See also Note [Translating unboxed sums to unboxed tuples]. + +Int32# and Int64# in this case will share the same slot in the unboxed sum. This means +the sum after unarise will be represented by two binders. One for the tag and one for +the field. The later having Int64Rep. +However our input for the field is of Int32Rep. So in order to soundly construct +`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#. +To do this mkUbxSum will produce an expression with a hole for constructor application +to go into. That is the call to mkUbxSum and it's result will look something like: + + >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x') + ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs ) + +We will use the returned arguments to construct an application to an unboxed tuple: + + >>> mkTuple [tag::Int#, x'::Int64#] + (# tag, x' #) + +Which we will then use as the rhs to pass into the casting wrapper to +construct an expression that casts `x` to the right type before constructing the +tuple + + >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #) + case int32ToInt# x of x' -> (# #) 1# x' + +Which results in the this definition for `sum` after all is said and done: + + let sum = case int32ToInt# x of { x' -> (# #) 1# x' } + +Not that the renaming is not optional. Cmm requires binders of different uniques +to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids + +------------- A full example of casting during sum matching -------------------- + +When matching on an unboxed sum constructor we start out with +something like this the pre-unarise: + + f :: (# Int32 | Int64# ) -> ... + f sum = case sum of + (# x |#) -> alt_rhs + ... + +We unarise the function arguments and get: + + f sum_tag sum_slot1 = case sum_tag of + 1# -> ??? + +Now we need to match up the original alternative binders with the sum slots passed +to the function. This is done by mapSumIdBinders which we we call for our +example alternative like this: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + (env', alt_rhs') + +mapSumIdBinders first matches up the list of binders with the slots passed to +the function which is trivial in this case. Then we check if the slot and the +variable residing inside it agree on their Rep. If alternative binders and +the function arguments agree in their slot reps we we just extend the environment +with a mapping from `x` to `sum_slot1` and we return the rhs as is. + +If the reps of the sum_slots do not agree with alternative binders they represent +then we need to wrap the whole RHS in nested cases which cast the sum_slot<n> +variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be +of Int64Rep. This means instead of retuning the original alt_rhs we will return: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + ( env'[x=x'] + , case int64ToInt32# (sum_slot1 :: Int64#) of + (x' :: Int32#) -> alt_rhs + ) + +We then run unarise on alt_rhs within that expression, which will replace the first occurence +of `x` with sum_slot_arg_1 giving us post-unarise: + + f sum_tag sum_slot1 = + case sum_tag of + 1# -> case int64ToInt32# sum_slot1 of + x' -> ... x' ... + ... + Note [UnariseEnv] ~~~~~~~~~~~~~~~~~~ At any variable occurrence 'v', @@ -256,8 +379,8 @@ import GHC.Prelude import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon -import GHC.Core.TyCon ( isVoidRep ) -import GHC.Data.FastString (FastString, mkFastString) +import GHC.Core.TyCon +import GHC.Data.FastString (FastString, mkFastString, fsLit) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) @@ -273,6 +396,7 @@ import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply +import GHC.Types.Unique import GHC.Utils.Misc import GHC.Types.Var.Env @@ -280,7 +404,11 @@ import Data.Bifunctor (second) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Casts +import Data.List (mapAccumL) +-- import GHC.Utils.Trace -------------------------------------------------------------------------------- -- | A mapping from binders to the Ids they were expanded/renamed to. @@ -305,8 +433,10 @@ import qualified Data.IntMap as IM -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes -- (i.e. no unboxed tuples, sums or voids) -- -type UnariseEnv = VarEnv UnariseVal +newtype UnariseEnv = UnariseEnv { ue_rho :: (VarEnv UnariseVal) } +initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv +initUnariseEnv = UnariseEnv data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). | UnaryVal OutStgArg -- See Note [Renaming during unarisation]. @@ -319,25 +449,27 @@ instance Outputable UnariseVal where -- The id is mapped to one or more things. -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv -extendRho rho x (MultiVal args) +extendRho env x (MultiVal args) = assert (all (isNvUnaryType . stgArgType) args) - extendVarEnv rho x (MultiVal args) -extendRho rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) } +extendRho env x (UnaryVal val) = assert (isNvUnaryType (stgArgType val)) - extendVarEnv rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) } -- Properly shadow things from an outer scope. -- See Note [UnariseEnv] -- The id stands for itself so we don't record a mapping. -- See Note [UnariseEnv] extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv -extendRhoWithoutValue rho x = delVarEnv rho x +extendRhoWithoutValue env x = env { ue_rho = delVarEnv (ue_rho env) x } +lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal +lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] -unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) +unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -365,7 +497,7 @@ unariseRhs rho (StgRhsCon ccs con mu ts args) unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr unariseExpr rho e@(StgApp f []) - = case lookupVarEnv rho f of + = case lookupRho rho f of Just (MultiVal args) -- Including empty tuples -> return (mkTuple args) Just (UnaryVal (StgVarArg f')) @@ -378,7 +510,7 @@ unariseExpr rho e@(StgApp f []) unariseExpr rho e@(StgApp f args) = return (StgApp f' (unariseFunArgs rho args)) where - f' = case lookupVarEnv rho f of + f' = case lookupRho rho f of Just (UnaryVal (StgVarArg f')) -> f' Nothing -> f err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) @@ -389,12 +521,17 @@ unariseExpr _ (StgLit l) = return (StgLit l) unariseExpr rho (StgConApp dc n args ty_args) - | Just args' <- unariseMulti_maybe rho dc args ty_args - = return (mkTuple args') - - | otherwise - , let args' = unariseConArgs rho args - = return (StgConApp dc n args' (map stgArgType args')) + | isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args', Just cast_wrapper) + -> return $ cast_wrapper (mkTuple args') + (args', Nothing) + -> return $ (mkTuple args') + | otherwise = + let args' = unariseConArgs rho args in + return $ (StgConApp dc n args' (map stgArgType args')) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -402,15 +539,19 @@ unariseExpr rho (StgOpApp op args ty) unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated | StgApp v [] <- scrut - , Just (MultiVal xs) <- lookupVarEnv rho v + , Just (MultiVal xs) <- lookupRho rho v = elimCase rho xs bndr alt_ty alts -- Handle strict lets for tuples and sums: -- case (# a,b #) of r -> rhs -- and analogously for sums | StgConApp dc _n args ty_args <- scrut - , Just args' <- unariseMulti_maybe rho dc args ty_args - = elimCase rho args' bndr alt_ty alts + , isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args',Just wrapper) -> wrapper <$> elimCase rho args' bndr alt_ty alts + (args',Nothing) -> elimCase rho args' bndr alt_ty alts -- See (3) of Note [Rubbish literals] in GHC.Types.Literal | StgLit lit <- scrut @@ -435,17 +576,21 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] -unariseMulti_maybe rho dc args ty_args +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] + -> ( [OutStgArg] -- Arguments representing the unboxed sum + , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them + -- into the right Rep +unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedTupleDataCon dc - = Just (unariseConArgs rho args) + = (unariseConArgs rho args, Nothing) | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = Just (mkUbxSum dc ty_args args1) + = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + in (args2, Just cast_wrapper) | otherwise - = Nothing + = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple" -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] @@ -472,15 +617,19 @@ elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _ , alt_bndrs = bndrs , alt_rhs = rhs}] = do let rho1 = extendRho rho bndr (MultiVal args) - rho2 + (rho2, rhs') <- case () of + _ | isUnboxedTupleBndr bndr - = mapTupleIdBinders bndrs args rho1 + -> return (mapTupleIdBinders bndrs args rho1, rhs) | otherwise - = assert (isUnboxedSumBndr bndr) $ - if null bndrs then rho1 - else mapSumIdBinders bndrs args rho1 + -> assert (isUnboxedSumBndr bndr) $ + case bndrs of + -- Sum with a void-type binder? + [] -> return (rho1, rhs) + [alt_bndr] -> mapSumIdBinders alt_bndr args rhs rho1 + _ -> pprPanic "mapSumIdBinders" (ppr bndrs $$ ppr args) - unariseExpr rho2 rhs + unariseExpr rho2 rhs' elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr @@ -570,18 +719,23 @@ unariseSumAlt :: UnariseEnv unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e} = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args GenStgAlt{ alt_con = DataAlt sumCon +unariseSumAlt rho args alt@GenStgAlt{ alt_con = DataAlt sumCon , alt_bndrs = bs , alt_rhs = e } - = do let rho' = mapSumIdBinders bs args rho - lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) - GenStgAlt lit_case mempty <$> unariseExpr rho' e + + = do (rho',e') <- case bs of + [b] -> mapSumIdBinders b args e rho + -- Sums must have one binder + _ -> pprPanic "unariseSumAlt2" (ppr args $$ pprPanicAlt alt) + let lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) + GenStgAlt lit_case mempty <$> unariseExpr rho' e' unariseSumAlt _ scrt alt - = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt) + = pprPanic "unariseSumAlt3" (ppr scrt $$ pprPanicAlt alt) -------------------------------------------------------------------------------- +-- Mapping binders when matching und a unboxed sum/tuple mapTupleIdBinders :: [InId] -- Un-processed binders of a tuple alternative. @@ -617,27 +771,90 @@ mapTupleIdBinders ids args0 rho0 map_ids rho0 ids_unarised args0 mapSumIdBinders - :: [InId] -- Binder of a sum alternative (remember that sum patterns - -- only have one binder, so this list should be a singleton) + :: InId -- Binder (in the case alternative). -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). -- Can't have void args. + -> InStgExpr -> UnariseEnv - -> UnariseEnv + -> UniqSM (UnariseEnv, OutStgExpr) -mapSumIdBinders [id] args rho0 - = assert (not (any (isZeroBitTy . stgArgType) args)) $ +mapSumIdBinders alt_bndr args rhs rho0 + = assert (not (any (isZeroBitTy . stgArgType) args)) $ do + uss <- listSplitUniqSupply <$> getUniqueSupplyM let + fld_reps = typePrimRep (idType alt_bndr) + + -- Slots representing the whole sum arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args - id_slots = map primRepSlot $ typePrimRep (idType id) + -- The slots representing the field of the sum we bind. + id_slots = map primRepSlot $ fld_reps layout1 = layoutUbxSum arg_slots id_slots - in - if isMultiValBndr id - then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) - else assert (layout1 `lengthIs` 1) - extendRho rho0 id (UnaryVal (args !! head layout1)) -mapSumIdBinders ids sum_args _ - = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) + -- See Note [Casting slot arguments] + -- Most of the code here is just to make sure our binders are of the + -- right type. + -- Select only the args which contain parts of the current field. + id_arg_exprs = [ args !! i | i <- layout1 ] + id_vars = [v | StgVarArg v <- id_arg_exprs] + -- Output types for the field binders based on their rep + id_tys = map primRepToType fld_reps + + typed_id_arg_input = assert (equalLength id_vars id_tys) $ + zip3 id_vars id_tys uss + + mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,tar_type,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + cst_opts = zip3 ops types $ uniqsFromSupply bndr_us + out_id = case cst_opts of + [] -> id + _ -> let (_,ty,uq) = last cst_opts + in mkCastVar uq ty + in (cst_opts,id,out_id) + + cast_inputs = map mkCastInput typed_id_arg_input + (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs + where + cast_arg rhs_in (cast_ops,in_id,out_id) = + let rhs_out = castArgRename cast_ops (StgVarArg in_id) + in (rhs_in . rhs_out, out_id) + + typed_id_args = map StgVarArg typed_ids + + -- pprTrace "mapSumIdBinders" + -- (text "id_tys" <+> ppr id_tys $$ + -- text "id_args" <+> ppr id_arg_exprs $$ + -- text "rhs" <+> ppr rhs $$ + -- text "rhs_with_casts" <+> ppr rhs_with_casts + -- ) $ + if isMultiValBndr alt_bndr + then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) + else assert (typed_id_args `lengthIs` 1) $ + return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs) + +-- Convert the argument to the given type, and wrap the conversion +-- around the given expression. Use the given Id as a name for the +-- converted value. +castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr +castArgRename ops in_arg rhs = + case ops of + [] -> rhs + ((op,ty,uq):rest_ops) -> + let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty + sub_cast = castArgRename rest_ops (StgVarArg out_id') + in mkCast in_arg op out_id' ty $ sub_cast rhs + +-- Construct a case binder used when casting sums, of a given type and unique. +mkCastVar :: Unique -> Type -> Id +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty + +mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr +mkCast arg_in cast_op out_id out_ty in_rhs = + let r2 = typePrimRep1 out_ty + scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty + alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} + alt_ty = PrimAlt r2 + in (StgCase scrut out_id alt_ty [alt]) -- | Build a unboxed sum term from arguments of an alternative. -- @@ -650,31 +867,72 @@ mapSumIdBinders ids sum_args _ -- [ 1#, rubbish ] -- mkUbxSum - :: DataCon -- Sum data con + :: HasDebugCallStack + => DataCon -- Sum data con -> [Type] -- Type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. - -> [OutStgArg] -- Final tuple arguments -mkUbxSum dc ty_args args0 + -> UniqSupply + -> ([OutStgArg] -- Final tuple arguments + ,(StgExpr->StgExpr) -- We might need to cast the args first + ) +mkUbxSum dc ty_args args0 us = let _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) - -- drop tag slot - + -- drop tag slot + field_slots = (mapMaybe (typeSlotTy . stgArgType) args0) tag = dataConTag dc + layout' = layoutUbxSum sum_slots field_slots - layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) - mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] - mkTupArgs _ [] _ - = [] - mkTupArgs arg_idx (slot : slots_left) arg_map - | Just stg_arg <- IM.lookup arg_idx arg_map - = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map - | otherwise - = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map + ((_idx,_idx_map,_us,wrapper),slot_args) + = assert (length arg_idxs <= length sum_slots ) $ + mapAccumL mkTupArg (0,arg_idxs,us,id) sum_slots + + mkTupArg :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr) + -> SlotTy + -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg) + mkTupArg (arg_idx, arg_map, us, wrapper) slot + | Just stg_arg <- IM.lookup arg_idx arg_map + = case castArg us slot stg_arg of + -- Slot and arg type missmatched, do a cast + Just (casted_arg,us',wrapper') -> + ( (arg_idx+1, arg_map, us', wrapper . wrapper') + , casted_arg) + -- Use the arg as-is + Nothing -> + ( (arg_idx+1, arg_map, us, wrapper) + , stg_arg) + -- Garbage slot, fill with rubbish + | otherwise + = ( (arg_idx+1, arg_map, us, wrapper) + , ubxSumRubbishArg slot) + + castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg + -- Cast the argument to the type of the slot if required + | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg) + , out_ty <- primRepToType $ slotPrimRep slot_ty + , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty + , not . null $ ops + = let (us1,us2) = splitUniqSupply us + cast_uqs = uniqsFromSupply us1 + cast_opts = zip3 ops types cast_uqs + (_op,out_ty,out_uq) = last cast_opts + casts = castArgRename cast_opts arg :: StgExpr -> StgExpr + in Just (StgVarArg (mkCastVar out_uq out_ty),us2,casts) + -- No need for casting + | otherwise = Nothing + + tup_args = tag_arg : slot_args in - tag_arg : mkTupArgs 0 sum_slots arg_idxs + -- pprTrace "mkUbxSum" ( + -- text "ty_args (slots)" <+> ppr ty_args $$ + -- text "args0" <+> ppr args0 $$ + -- text "wrapper" <+> + -- (ppr $ wrapper $ StgLit $ LitChar '_')) + (tup_args, wrapper) -- | Return a rubbish value for the given slot type. @@ -787,7 +1045,7 @@ unariseArgBinder is_con_arg rho x = -- | MultiVal a function argument. Never returns an empty list. unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] unariseFunArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (MultiVal []) -> [voidArg] -- NB: do not remove void args Just (MultiVal as) -> as Just (UnaryVal arg) -> [arg] @@ -809,7 +1067,7 @@ unariseFunArgBinder = unariseArgBinder False -- | MultiVal a DataCon argument. Returns an empty list when argument is void. unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] unariseConArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (UnaryVal arg) -> [arg] Just (MultiVal as) -> as -- 'as' can be empty Nothing |