-\begin{code}
-cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
-cpr_flatten ty cpr_info
- = mk_cpr_case (ty, cpr_info) `thenUs` \(res_id, tup_ids, flatten_exp) ->
- returnUs (\body -> Case body res_id
- [(DEFAULT, [], flatten_exp (fst $ mk_unboxed_tuple tup_ids))])
-
-
-
-mk_cpr_case :: (Type, CprInfo) ->
- UniqSM (CoreBndr, -- Name of binder for this part of result
- [(CoreExpr, Type)], -- expressions for flattened result
- CoreExpr -> CoreExpr) -- add in code to flatten result
-
-mk_cpr_case (ty, NoCPRInfo)
- -- this component must be returned as a component of the unboxed tuple result
- = getUniqueUs `thenUs` \id_uniq ->
- let id_id = mk_ww_local id_uniq ty in
- returnUs (id_id, [(Var id_id, ty)], id)
-mk_cpr_case (ty, cpr_info@(CPRInfo ci_args))
- | isNewTyCon tycon -- a new type: under the coercions must be a
- -- constructed product
- = ASSERT ( null $ tail inst_con_arg_tys )
- mk_cpr_case (target_of_from_type, cpr_info)
- `thenUs` \(arg, tup, exp) ->
- getUniqueUs `thenUs` \id_uniq ->
- let id_id = mk_ww_local id_uniq ty
- new_exp_case = \var -> Case (Note (Coerce (idType arg) ty) (Var id_id))
- arg
- [(DEFAULT,[], exp var)]
- in
- returnUs (id_id, tup, new_exp_case)
-
- | otherwise -- a data type
- -- flatten components
- = mapUs mk_cpr_case (zip inst_con_arg_tys ci_args)
- `thenUs` \sub_builds ->
- getUniqueUs `thenUs` \id_uniq ->
- let id_id = mk_ww_local id_uniq ty
- (args, tup, exp) = unzip3 sub_builds
- con_app = mkConApp data_con (map Var args)
- new_tup = concat tup
- new_exp_case = \var -> Case (Var id_id) (mkWildId ty)
- [(DataCon data_con, args,
- foldl (\e f -> f e) var exp)]