never executed always true always false
    1 
    2 {-# LANGUAGE FlexibleContexts #-}
    3 {-# LANGUAGE TupleSections    #-}
    4 
    5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    6 
    7 {-
    8 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
    9 
   10 Note [Unarisation]
   11 ~~~~~~~~~~~~~~~~~~
   12 The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
   13 binders. So for example:
   14 
   15   f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
   16 
   17   ==>
   18 
   19   f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
   20 
   21 It is important that we do this at the STG level and NOT at the Core level
   22 because it would be very hard to make this pass Core-type-preserving. In this
   23 example the type of 'f' changes, for example.
   24 
   25 STG fed to the code generators *must* be unarised because the code generators do
   26 not support unboxed tuple and unboxed sum binders natively.
   27 
   28 In more detail: (see next note for unboxed sums)
   29 
   30 Suppose that a variable x : (# t1, t2 #).
   31 
   32   * At the binding site for x, make up fresh vars  x1:t1, x2:t2
   33 
   34   * Extend the UnariseEnv   x :-> MultiVal [x1,x2]
   35 
   36   * Replace the binding with a curried binding for x1,x2
   37 
   38        Lambda:   \x.e                ==>   \x1 x2. e
   39        Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e
   40 
   41   * Replace argument occurrences with a sequence of args via a lookup in
   42     UnariseEnv
   43 
   44        f a b x c d   ==>   f a b x1 x2 c d
   45 
   46   * Replace tail-call occurrences with an unboxed tuple via a lookup in
   47     UnariseEnv
   48 
   49        x  ==>  (# x1, x2 #)
   50 
   51     So, for example
   52 
   53        f x = x    ==>   f x1 x2 = (# x1, x2 #)
   54 
   55   * We /always/ eliminate a case expression when
   56 
   57        - It scrutinises an unboxed tuple or unboxed sum
   58 
   59        - The scrutinee is a variable (or when it is an explicit tuple, but the
   60          simplifier eliminates those)
   61 
   62     The case alternative (there can be only one) can be one of these two
   63     things:
   64 
   65       - An unboxed tuple pattern. e.g.
   66 
   67           case v of x { (# x1, x2, x3 #) -> ... }
   68 
   69         Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
   70         environment with
   71 
   72           x :-> MultiVal [t1,t2,t3]
   73           x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
   74 
   75       - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
   76 
   77 By the end of this pass, we only have unboxed tuples in return positions.
   78 Unboxed sums are completely eliminated, see next note.
   79 
   80 Note [Translating unboxed sums to unboxed tuples]
   81 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   82 Unarise also eliminates unboxed sum binders, and translates unboxed sums in
   83 return positions to unboxed tuples. We want to overlap fields of a sum when
   84 translating it to a tuple to have efficient memory layout. When translating a
   85 sum pattern to a tuple pattern, we need to translate it so that binders of sum
   86 alternatives will be mapped to right arguments after the term translation. So
   87 translation of sum DataCon applications to tuple DataCon applications and
   88 translation of sum patterns to tuple patterns need to be in sync.
   89 
   90 These translations work like this. Suppose we have
   91 
   92   (# x1 | | ... #) :: (# t1 | t2 | ... #)
   93 
   94 remember that t1, t2 ... can be sums and tuples too. So we first generate
   95 layouts of those. Then we "merge" layouts of each alternative, which gives us a
   96 sum layout with best overlapping possible.
   97 
   98 Layout of a flat type 'ty1' is just [ty1].
   99 Layout of a tuple is just concatenation of layouts of its fields.
  100 
  101 For layout of a sum type,
  102 
  103   - We first get layouts of all alternatives.
  104   - We sort these layouts based on their "slot types".
  105   - We merge all the alternatives.
  106 
  107 For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
  108 
  109   - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]
  110   - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]
  111   - Merge all alternatives together: [ LiftedPtr, Word, Word ]
  112 
  113 We add a slot for the tag to the first position. So our tuple type is
  114 
  115   (# Tag#, Any, Word#, Word# #)
  116   (we use Any for pointer slots)
  117 
  118 Now, any term of this sum type needs to generate a tuple of this type instead.
  119 The translation works by simply putting arguments to first slots that they fit
  120 in. Suppose we had
  121 
  122   (# (# 42#, 'c' #) | | #)
  123 
  124 42# fits in Word#, 'c' fits in Any, so we generate this application:
  125 
  126   (# 1#, 'c', 42#, rubbish #)
  127 
  128 Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
  129 3# fits in Word #, so we get:
  130 
  131   (# 2#, rubbish, 2#, 3# #).
  132 
  133 
  134 Note [Don't merge lifted and unlifted slots]
  135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  136 When merging slots, one might be tempted to collapse lifted and unlifted
  137 pointers. However, as seen in #19645, this is wrong. Imagine that you have
  138 the program:
  139 
  140   test :: (# Char | ByteArray# #) -> ByteArray#
  141   test (# c | #) = doSomething c
  142   test (# | ba #) = ba
  143 
  144 Collapsing the Char and ByteArray# slots would produce STG like:
  145 
  146   test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#
  147     = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]
  148           case tag of tag'
  149             1# -> doSomething slot0
  150             2# -> slot0;
  151 
  152 Note how `slot0` has a lifted type, despite being bound to an unlifted
  153 ByteArray# in the 2# alternative. This liftedness would cause the code generator to
  154 attempt to enter it upon returning. As unlifted objects do not have entry code,
  155 this causes a runtime crash.
  156 
  157 For this reason, Unarise treats unlifted and lifted things as distinct slot
  158 types, despite both being GC pointers. This approach is a slight pessimisation
  159 (since we need to pass more arguments) but appears to be the simplest way to
  160 avoid #19645. Other alternatives considered include:
  161 
  162  a. Giving unlifted objects "trivial" entry code. However, we ultimately
  163     concluded that the value of the "unlifted things are never entered" invariant
  164     outweighed the simplicity of this approach.
  165 
  166  b. Annotating occurrences with calling convention information instead of
  167     relying on the binder's type. This seemed like a very complicated
  168     way to fix what is ultimately a corner-case.
  169 
  170 
  171 Note [Types in StgConApp]
  172 ~~~~~~~~~~~~~~~~~~~~~~~~~
  173 Suppose we have this unboxed sum term:
  174 
  175   (# 123 | #)
  176 
  177 What will be the unboxed tuple representation? We can't tell without knowing the
  178 type of this term. For example, these are all valid tuples for this:
  179 
  180   (# 1#, 123 #)          -- when type is (# Int | String #)
  181   (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
  182   (# 1#, 123, rubbish, rubbish #)
  183                          -- when type is (# Int | (# Int, Int, Int #) #)
  184 
  185 So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
  186 layout to use. Note that unlifted values can't be let-bound, so we don't need
  187 types in StgRhsCon.
  188 
  189 Note [UnariseEnv can map to literals]
  190 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  191 To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
  192 needs to map variables to literals too. Suppose we have this Core:
  193 
  194   f (# x | #)
  195 
  196   ==> (CorePrep)
  197 
  198   case (# x | #) of y {
  199     _ -> f y
  200   }
  201 
  202   ==> (MultiVal)
  203 
  204   case (# 1#, x #) of [x1, x2] {
  205     _ -> f x1 x2
  206   }
  207 
  208 To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
  209 
  210   x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
  211 
  212 so that `f x1 x2` becomes `f 1# x`.
  213 
  214 Note [Unarisation and arity]
  215 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  216 Because of unarisation, the arity that will be recorded in the generated info
  217 table for an Id may be larger than the idArity. Instead we record what we call
  218 the RepArity, which is the Arity taking into account any expanded arguments, and
  219 corresponds to the number of (possibly-void) *registers* arguments will arrive
  220 in.
  221 
  222 Note [Post-unarisation invariants]
  223 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  224 STG programs after unarisation have these invariants:
  225 
  226   * No unboxed sums at all.
  227 
  228   * No unboxed tuple binders. Tuples only appear in return position.
  229 
  230   * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
  231     This means that it's safe to wrap `StgArg`s of DataCon applications with
  232     `GHC.StgToCmm.Env.NonVoid`, for example.
  233 
  234   * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only
  235     appear in return position.
  236 
  237   * Alt binders (binders in patterns) are always non-void.
  238 
  239   * Binders always have zero (for void arguments) or one PrimRep.
  240 -}
  241 
  242 module GHC.Stg.Unarise (unarise) where
  243 
  244 import GHC.Prelude
  245 
  246 import GHC.Types.Basic
  247 import GHC.Core
  248 import GHC.Core.DataCon
  249 import GHC.Core.TyCon ( isVoidRep )
  250 import GHC.Data.FastString (FastString, mkFastString)
  251 import GHC.Types.Id
  252 import GHC.Types.Literal
  253 import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
  254 import GHC.Types.Id.Make (voidPrimId, voidArgId)
  255 import GHC.Utils.Monad (mapAccumLM)
  256 import GHC.Utils.Outputable
  257 import GHC.Utils.Panic
  258 import GHC.Utils.Panic.Plain
  259 import GHC.Types.RepType
  260 import GHC.Stg.Syntax
  261 import GHC.Core.Type
  262 import GHC.Builtin.Types.Prim (intPrimTy)
  263 import GHC.Builtin.Types
  264 import GHC.Types.Unique.Supply
  265 import GHC.Utils.Misc
  266 import GHC.Types.Var.Env
  267 
  268 import Data.Bifunctor (second)
  269 import Data.Maybe (mapMaybe)
  270 import qualified Data.IntMap as IM
  271 
  272 --------------------------------------------------------------------------------
  273 
  274 -- | A mapping from binders to the Ids they were expanded/renamed to.
  275 --
  276 --   x :-> MultiVal [a,b,c] in rho
  277 --
  278 -- iff  x's typePrimRep is not a singleton, or equivalently
  279 --      x's type is an unboxed tuple, sum or void.
  280 --
  281 --    x :-> UnaryVal x'
  282 --
  283 -- iff x's RepType is UnaryRep or equivalently
  284 --     x's type is not unboxed tuple, sum or void.
  285 --
  286 -- So
  287 --     x :-> MultiVal [a] in rho
  288 -- means x is represented by singleton tuple.
  289 --
  290 --     x :-> MultiVal [] in rho
  291 -- means x is void.
  292 --
  293 -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
  294 --            (i.e. no unboxed tuples, sums or voids)
  295 --
  296 type UnariseEnv = VarEnv UnariseVal
  297 
  298 data UnariseVal
  299   = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
  300   | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].
  301 
  302 instance Outputable UnariseVal where
  303   ppr (MultiVal args) = text "MultiVal" <+> ppr args
  304   ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
  305 
  306 -- | Extend the environment, checking the UnariseEnv invariant.
  307 extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
  308 extendRho rho x (MultiVal args)
  309   = assert (all (isNvUnaryType . stgArgType) args)
  310     extendVarEnv rho x (MultiVal args)
  311 extendRho rho x (UnaryVal val)
  312   = assert (isNvUnaryType (stgArgType val))
  313     extendVarEnv rho x (UnaryVal val)
  314 
  315 --------------------------------------------------------------------------------
  316 
  317 unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
  318 unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
  319 
  320 unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
  321 unariseTopBinding rho (StgTopLifted bind)
  322   = StgTopLifted <$> unariseBinding rho bind
  323 unariseTopBinding _ bind@StgTopStringLit{} = return bind
  324 
  325 unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
  326 unariseBinding rho (StgNonRec x rhs)
  327   = StgNonRec x <$> unariseRhs rho rhs
  328 unariseBinding rho (StgRec xrhss)
  329   = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
  330 
  331 unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
  332 unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
  333   = do (rho', args1) <- unariseFunArgBinders rho args
  334        expr' <- unariseExpr rho' expr
  335        return (StgRhsClosure ext ccs update_flag args1 expr')
  336 
  337 unariseRhs rho (StgRhsCon ccs con mu ts args)
  338   = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
  339     return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
  340 
  341 --------------------------------------------------------------------------------
  342 
  343 unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
  344 
  345 unariseExpr rho e@(StgApp f [])
  346   = case lookupVarEnv rho f of
  347       Just (MultiVal args)  -- Including empty tuples
  348         -> return (mkTuple args)
  349       Just (UnaryVal (StgVarArg f'))
  350         -> return (StgApp f' [])
  351       Just (UnaryVal (StgLitArg f'))
  352         -> return (StgLit f')
  353       Nothing
  354         -> return e
  355 
  356 unariseExpr rho e@(StgApp f args)
  357   = return (StgApp f' (unariseFunArgs rho args))
  358   where
  359     f' = case lookupVarEnv rho f of
  360            Just (UnaryVal (StgVarArg f')) -> f'
  361            Nothing -> f
  362            err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err)
  363                -- Can't happen because 'args' is non-empty, and
  364                -- a tuple or sum cannot be applied to anything
  365 
  366 unariseExpr _ (StgLit l)
  367   = return (StgLit l)
  368 
  369 unariseExpr rho (StgConApp dc n args ty_args)
  370   | Just args' <- unariseMulti_maybe rho dc args ty_args
  371   = return (mkTuple args')
  372 
  373   | otherwise
  374   , let args' = unariseConArgs rho args
  375   = return (StgConApp dc n args' (map stgArgType args'))
  376 
  377 unariseExpr rho (StgOpApp op args ty)
  378   = return (StgOpApp op (unariseFunArgs rho args) ty)
  379 
  380 unariseExpr rho (StgCase scrut bndr alt_ty alts)
  381   -- tuple/sum binders in the scrutinee can always be eliminated
  382   | StgApp v [] <- scrut
  383   , Just (MultiVal xs) <- lookupVarEnv rho v
  384   = elimCase rho xs bndr alt_ty alts
  385 
  386   -- Handle strict lets for tuples and sums:
  387   --   case (# a,b #) of r -> rhs
  388   -- and analogously for sums
  389   | StgConApp dc _n args ty_args <- scrut
  390   , Just args' <- unariseMulti_maybe rho dc args ty_args
  391   = elimCase rho args' bndr alt_ty alts
  392 
  393   -- See (3) of Note [Rubbish literals] in GHC.Types.Literal
  394   | StgLit lit <- scrut
  395   , Just args' <- unariseRubbish_maybe lit
  396   = elimCase rho args' bndr alt_ty alts
  397 
  398   -- general case
  399   | otherwise
  400   = do scrut' <- unariseExpr rho scrut
  401        alts'  <- unariseAlts rho alt_ty bndr alts
  402        return (StgCase scrut' bndr alt_ty alts')
  403                        -- bndr may have a unboxed sum/tuple type but it will be
  404                        -- dead after unarise (checked in GHC.Stg.Lint)
  405 
  406 unariseExpr rho (StgLet ext bind e)
  407   = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
  408 
  409 unariseExpr rho (StgLetNoEscape ext bind e)
  410   = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
  411 
  412 unariseExpr rho (StgTick tick e)
  413   = StgTick tick <$> unariseExpr rho e
  414 
  415 -- Doesn't return void args.
  416 unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
  417 unariseMulti_maybe rho dc args ty_args
  418   | isUnboxedTupleDataCon dc
  419   = Just (unariseConArgs rho args)
  420 
  421   | isUnboxedSumDataCon dc
  422   , let args1 = assert (isSingleton args) (unariseConArgs rho args)
  423   = Just (mkUbxSum dc ty_args args1)
  424 
  425   | otherwise
  426   = Nothing
  427 
  428 -- Doesn't return void args.
  429 unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
  430 unariseRubbish_maybe (LitRubbish rep)
  431   | [prep] <- preps
  432   , not (isVoidRep prep)
  433   = Nothing   -- Single, non-void PrimRep. Nothing to do!
  434 
  435   | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase
  436   = Just [ StgLitArg (LitRubbish (primRepToType prep))
  437          | prep <- preps, not (isVoidRep prep) ]
  438   where
  439     preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep
  440 
  441 unariseRubbish_maybe _ = Nothing
  442 
  443 --------------------------------------------------------------------------------
  444 
  445 elimCase :: UnariseEnv
  446          -> [OutStgArg] -- non-void args
  447          -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
  448 
  449 elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
  450   = do let rho1 = extendRho rho bndr (MultiVal args)
  451            rho2
  452              | isUnboxedTupleBndr bndr
  453              = mapTupleIdBinders bndrs args rho1
  454              | otherwise
  455              = assert (isUnboxedSumBndr bndr) $
  456                if null bndrs then rho1
  457                              else mapSumIdBinders bndrs args rho1
  458 
  459        unariseExpr rho2 rhs
  460 
  461 elimCase rho args bndr (MultiValAlt _) alts
  462   | isUnboxedSumBndr bndr
  463   = do let (tag_arg : real_args) = args
  464        tag_bndr <- mkId (mkFastString "tag") tagTy
  465           -- this won't be used but we need a binder anyway
  466        let rho1 = extendRho rho bndr (MultiVal args)
  467            scrut' = case tag_arg of
  468                       StgVarArg v     -> StgApp v []
  469                       StgLitArg l     -> StgLit l
  470 
  471        alts' <- unariseSumAlts rho1 real_args alts
  472        return (StgCase scrut' tag_bndr tagAltTy alts')
  473 
  474 elimCase _ args bndr alt_ty alts
  475   = pprPanic "elimCase - unhandled case"
  476       (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts)
  477 
  478 --------------------------------------------------------------------------------
  479 
  480 unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
  481 unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
  482   | isUnboxedTupleBndr bndr
  483   = do (rho', ys) <- unariseConArgBinder rho bndr
  484        e' <- unariseExpr rho' e
  485        return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
  486 
  487 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
  488   | isUnboxedTupleBndr bndr
  489   = do (rho', ys1) <- unariseConArgBinders rho ys
  490        massert (ys1 `lengthIs` n)
  491        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
  492        e' <- unariseExpr rho'' e
  493        return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
  494 
  495 unariseAlts _ (MultiValAlt _) bndr alts
  496   | isUnboxedTupleBndr bndr
  497   = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)
  498 
  499 -- In this case we don't need to scrutinize the tag bit
  500 unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
  501   | isUnboxedSumBndr bndr
  502   = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
  503        rhs' <- unariseExpr rho_sum_bndrs rhs
  504        return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
  505 
  506 unariseAlts rho (MultiValAlt _) bndr alts
  507   | isUnboxedSumBndr bndr
  508   = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
  509        alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
  510        let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
  511        return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
  512                  scrt_bndrs,
  513                  inner_case) ]
  514 
  515 unariseAlts rho _ _ alts
  516   = mapM (\alt -> unariseAlt rho alt) alts
  517 
  518 unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
  519 unariseAlt rho (con, xs, e)
  520   = do (rho', xs') <- unariseConArgBinders rho xs
  521        (con, xs',) <$> unariseExpr rho' e
  522 
  523 --------------------------------------------------------------------------------
  524 
  525 -- | Make alternatives that match on the tag of a sum
  526 -- (i.e. generate LitAlts for the tag)
  527 unariseSumAlts :: UnariseEnv
  528                -> [StgArg] -- sum components _excluding_ the tag bit.
  529                -> [StgAlt] -- original alternative with sum LHS
  530                -> UniqSM [StgAlt]
  531 unariseSumAlts env args alts
  532   = do alts' <- mapM (unariseSumAlt env args) alts
  533        return (mkDefaultLitAlt alts')
  534 
  535 unariseSumAlt :: UnariseEnv
  536               -> [StgArg] -- sum components _excluding_ the tag bit.
  537               -> StgAlt   -- original alternative with sum LHS
  538               -> UniqSM StgAlt
  539 unariseSumAlt rho _ (DEFAULT, _, e)
  540   = ( DEFAULT, [], ) <$> unariseExpr rho e
  541 
  542 unariseSumAlt rho args (DataAlt sumCon, bs, e)
  543   = do let rho' = mapSumIdBinders bs args rho
  544        e' <- unariseExpr rho' e
  545        return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )
  546 
  547 unariseSumAlt _ scrt alt
  548   = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)
  549 
  550 --------------------------------------------------------------------------------
  551 
  552 mapTupleIdBinders
  553   :: [InId]       -- Un-processed binders of a tuple alternative.
  554                   -- Can have void binders.
  555   -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
  556                   -- Can't have void args.
  557   -> UnariseEnv
  558   -> UnariseEnv
  559 mapTupleIdBinders ids args0 rho0
  560   = assert (not (any (isVoidTy . stgArgType) args0)) $
  561     let
  562       ids_unarised :: [(Id, [PrimRep])]
  563       ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
  564 
  565       map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
  566       map_ids rho [] _  = rho
  567       map_ids rho ((x, x_reps) : xs) args =
  568         let
  569           x_arity = length x_reps
  570           (x_args, args') =
  571             assert (args `lengthAtLeast` x_arity)
  572             splitAt x_arity args
  573 
  574           rho'
  575             | x_arity == 1
  576             = assert (x_args `lengthIs` 1)
  577               extendRho rho x (UnaryVal (head x_args))
  578             | otherwise
  579             = extendRho rho x (MultiVal x_args)
  580         in
  581           map_ids rho' xs args'
  582     in
  583       map_ids rho0 ids_unarised args0
  584 
  585 mapSumIdBinders
  586   :: [InId]      -- Binder of a sum alternative (remember that sum patterns
  587                  -- only have one binder, so this list should be a singleton)
  588   -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
  589                  -- Can't have void args.
  590   -> UnariseEnv
  591   -> UnariseEnv
  592 
  593 mapSumIdBinders [id] args rho0
  594   = assert (not (any (isVoidTy . stgArgType) args)) $
  595     let
  596       arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
  597       id_slots  = map primRepSlot $ typePrimRep (idType id)
  598       layout1   = layoutUbxSum arg_slots id_slots
  599     in
  600       if isMultiValBndr id
  601         then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
  602         else assert (layout1 `lengthIs` 1)
  603              extendRho rho0 id (UnaryVal (args !! head layout1))
  604 
  605 mapSumIdBinders ids sum_args _
  606   = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
  607 
  608 -- | Build a unboxed sum term from arguments of an alternative.
  609 --
  610 -- Example, for (# x | #) :: (# (# #) | Int #) we call
  611 --
  612 --   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
  613 --
  614 -- which returns
  615 --
  616 --   [ 1#, rubbish ]
  617 --
  618 mkUbxSum
  619   :: DataCon      -- Sum data con
  620   -> [Type]       -- Type arguments of the sum data con
  621   -> [OutStgArg]  -- Actual arguments of the alternative.
  622   -> [OutStgArg]  -- Final tuple arguments
  623 mkUbxSum dc ty_args args0
  624   = let
  625       (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
  626         -- drop tag slot
  627 
  628       tag = dataConTag dc
  629 
  630       layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
  631       tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag))
  632       arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
  633 
  634       mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
  635       mkTupArgs _ [] _
  636         = []
  637       mkTupArgs arg_idx (slot : slots_left) arg_map
  638         | Just stg_arg <- IM.lookup arg_idx arg_map
  639         = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
  640         | otherwise
  641         = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
  642     in
  643       tag_arg : mkTupArgs 0 sum_slots arg_idxs
  644 
  645 
  646 -- | Return a rubbish value for the given slot type.
  647 --
  648 -- We use the following rubbish values:
  649 --    * Literals: 0 or 0.0
  650 --    * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
  651 --
  652 -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make"
  653 --
  654 ubxSumRubbishArg :: SlotTy -> StgArg
  655 ubxSumRubbishArg PtrLiftedSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
  656 ubxSumRubbishArg PtrUnliftedSlot  = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
  657 ubxSumRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0)
  658 ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0)
  659 ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
  660 ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
  661 
  662 --------------------------------------------------------------------------------
  663 
  664 {-
  665 For arguments (StgArg) and binders (Id) we have two kind of unarisation:
  666 
  667   - When unarising function arg binders and arguments, we don't want to remove
  668     void binders and arguments. For example,
  669 
  670       f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
  671       f x y z = <body>
  672 
  673     Here after unarise we should still get a function with arity 3. Similarly
  674     in the call site we shouldn't remove void arguments:
  675 
  676       f (# (# #), (# #) #) voidId rw
  677 
  678     When unarising <body>, we extend the environment with these binders:
  679 
  680       x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
  681 
  682     Because their rep types are `MultiRep []` (aka. void). This means that when
  683     we see `x` in a function argument position, we actually replace it with a
  684     void argument. When we see it in a DataCon argument position, we just get
  685     rid of it, because DataCon applications in STG are always saturated.
  686 
  687   - When unarising case alternative binders we remove void binders, but we
  688     still update the environment the same way, because those binders may be
  689     used in the RHS. Example:
  690 
  691       case x of y {
  692         (# x1, x2, x3 #) -> <RHS>
  693       }
  694 
  695     We know that y can't be void, because we don't scrutinize voids, so x will
  696     be unarised to some number of arguments, and those arguments will have at
  697     least one non-void thing. So in the rho we will have something like:
  698 
  699       x :-> MultiVal [xu1, xu2]
  700 
  701     Now, after we eliminate void binders in the pattern, we get exactly the same
  702     number of binders, and extend rho again with these:
  703 
  704       x1 :-> UnaryVal xu1
  705       x2 :-> MultiVal [] -- x2 is void
  706       x3 :-> UnaryVal xu2
  707 
  708     Now when we see x2 in a function argument position or in return position, we
  709     generate void#. In constructor argument position, we just remove it.
  710 
  711 So in short, when we have a void id,
  712 
  713   - We keep it if it's a lambda argument binder or
  714                        in argument position of an application.
  715 
  716   - We remove it if it's a DataCon field binder or
  717                          in argument position of a DataCon application.
  718 -}
  719 
  720 unariseArgBinder
  721     :: Bool -- data con arg?
  722     -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
  723 unariseArgBinder is_con_arg rho x =
  724   case typePrimRep (idType x) of
  725     []
  726       | is_con_arg
  727       -> return (extendRho rho x (MultiVal []), [])
  728       | otherwise -- fun arg, do not remove void binders
  729       -> return (extendRho rho x (MultiVal []), [voidArgId])
  730 
  731     [rep]
  732       -- Arg represented as single variable, but original type may still be an
  733       -- unboxed sum/tuple, e.g. (# Void# | Void# #).
  734       --
  735       -- While not unarising the binder in this case does not break any programs
  736       -- (because it unarises to a single variable), it triggers StgLint as we
  737       -- break the post-unarisation invariant that says unboxed tuple/sum
  738       -- binders should vanish. See Note [Post-unarisation invariants].
  739       | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
  740       -> do x' <- mkId (mkFastString "us") (primRepToType rep)
  741             return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
  742       | otherwise
  743       -> return (rho, [x])
  744 
  745     reps -> do
  746       xs <- mkIds (mkFastString "us") (map primRepToType reps)
  747       return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
  748 
  749 --------------------------------------------------------------------------------
  750 
  751 -- | MultiVal a function argument. Never returns an empty list.
  752 unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
  753 unariseFunArg rho (StgVarArg x) =
  754   case lookupVarEnv rho x of
  755     Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
  756     Just (MultiVal as)  -> as
  757     Just (UnaryVal arg) -> [arg]
  758     Nothing             -> [StgVarArg x]
  759 unariseFunArg _ arg = [arg]
  760 
  761 unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
  762 unariseFunArgs = concatMap . unariseFunArg
  763 
  764 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
  765 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
  766 
  767 -- Result list of binders is never empty
  768 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
  769 unariseFunArgBinder = unariseArgBinder False
  770 
  771 --------------------------------------------------------------------------------
  772 
  773 -- | MultiVal a DataCon argument. Returns an empty list when argument is void.
  774 unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
  775 unariseConArg rho (StgVarArg x) =
  776   case lookupVarEnv rho x of
  777     Just (UnaryVal arg) -> [arg]
  778     Just (MultiVal as) -> as      -- 'as' can be empty
  779     Nothing
  780       | isVoidTy (idType x) -> [] -- e.g. C realWorld#
  781                                   -- Here realWorld# is not in the envt, but
  782                                   -- is a void, and so should be eliminated
  783       | otherwise -> [StgVarArg x]
  784 unariseConArg _ arg@(StgLitArg lit)
  785   | Just as <- unariseRubbish_maybe lit
  786   = as
  787   | otherwise
  788   = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals
  789     [arg]
  790 
  791 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
  792 unariseConArgs = concatMap . unariseConArg
  793 
  794 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
  795 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
  796 
  797 -- Different from `unariseFunArgBinder`: result list of binders may be empty.
  798 -- See DataCon applications case in Note [Post-unarisation invariants].
  799 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
  800 unariseConArgBinder = unariseArgBinder True
  801 
  802 --------------------------------------------------------------------------------
  803 
  804 mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
  805 mkIds fs tys = mapM (mkId fs) tys
  806 
  807 mkId :: FastString -> UnaryType -> UniqSM Id
  808 mkId s t = mkSysLocalM s Many t
  809 
  810 isMultiValBndr :: Id -> Bool
  811 isMultiValBndr id
  812   | [_] <- typePrimRep (idType id)
  813   = False
  814   | otherwise
  815   = True
  816 
  817 isUnboxedSumBndr :: Id -> Bool
  818 isUnboxedSumBndr = isUnboxedSumType . idType
  819 
  820 isUnboxedTupleBndr :: Id -> Bool
  821 isUnboxedTupleBndr = isUnboxedTupleType . idType
  822 
  823 mkTuple :: [StgArg] -> StgExpr
  824 mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args)
  825 
  826 tagAltTy :: AltType
  827 tagAltTy = PrimAlt IntRep
  828 
  829 tagTy :: Type
  830 tagTy = intPrimTy
  831 
  832 voidArg :: StgArg
  833 voidArg = StgVarArg voidPrimId
  834 
  835 mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
  836 -- We have an exhauseive list of literal alternatives
  837 --    1# -> e1
  838 --    2# -> e2
  839 -- Since they are exhaustive, we can replace one with DEFAULT, to avoid
  840 -- generating a final test. Remember, the DEFAULT comes first if it exists.
  841 mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
  842 mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
  843 mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
  844 mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)
  845 
  846 pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
  847 pprPanicAlts alts = ppr (map pprPanicAlt alts)
  848 
  849 pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
  850 pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)