+
+
+-- (mkReboxingAlt us con xs rhs) basically constructs the case
+-- alternative (con, xs, rhs)
+-- but it does the reboxing necessary to construct the *source*
+-- arguments, xs, from the representation arguments ys.
+-- For example:
+-- data T = MkT !(Int,Int) Bool
+--
+-- mkReboxingAlt MkT [x,b] r
+-- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
+--
+-- mkDataAlt should really be in DataCon, but it can't because
+-- it manipulates CoreSyn.
+
+mkReboxingAlt
+ :: [Unique] -- Uniques for the new Ids
+ -> DataCon
+ -> [Var] -- Source-level args
+ -> CoreExpr -- RHS
+ -> CoreAlt
+
+mkReboxingAlt us con args rhs
+ | not (any isMarkedUnboxed stricts)
+ = (DataAlt con, args, rhs)
+
+ | otherwise
+ = let
+ (binds, args') = go args stricts us
+ in
+ (DataAlt con, args', mkLets binds rhs)
+
+ where
+ stricts = dataConStrictMarks con
+
+ go [] stricts us = ([], [])
+
+ -- Type variable case
+ go (arg:args) stricts us
+ | isTyVar arg
+ = let (binds, args') = go args stricts us
+ in (binds, arg:args')
+
+ -- Term variable case
+ go (arg:args) (str:stricts) us
+ | isMarkedUnboxed str
+ = let
+ (_, tycon_args, pack_con, con_arg_tys)
+ = splitProductType "mkReboxingAlt" (idType arg)
+
+ unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+ (binds, args') = go args stricts (dropList con_arg_tys us)
+ con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+ in
+ (NonRec arg con_app : binds, unpacked_args ++ args')
+
+ | otherwise
+ = let (binds, args') = go args stricts us
+ in (binds, arg:args')