-mkDataConWrapId data_con
- = wrap_id
- where
- wrap_id = mkId (dataConName data_con) wrap_ty info
- work_id = dataConId data_con
-
- info = mkIdInfo (DataConWrapId data_con) NoCafRefs
- `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
- `setCprInfo` cpr_info
- -- The Cpr info can be important inside INLINE rhss, where the
- -- wrapper constructor isn't inlined
- `setArityInfo` exactArity arity
- -- It's important to specify the arity, so that partial
- -- applications are treated as values
- `setTyGenInfo` TyGenNever
- -- No point generalising its type, since it gets eagerly inlined
- -- away anyway
-
- wrap_ty = mkForAllTys all_tyvars $
- mkFunTys all_arg_tys
- result_ty
-
- cpr_info = idCprInfo work_id
-
- wrap_rhs | isNewTyCon tycon
- = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
- -- No existentials on a newtype, but it can have a context
- -- e.g. newtype Eq a => T a = MkT (...)
-
- mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
- Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
-
- | null dict_args && all not_marked_strict strict_marks
- = Var work_id -- The common case. Not only is this efficient,
- -- but it also ensures that the wrapper is replaced
- -- by the worker even when there are no args.
- -- f (:) x
- -- becomes
- -- f $w: x
- -- This is really important in rule matching,
- -- (We could match on the wrappers,
- -- but that makes it less likely that rules will match
- -- when we bring bits of unfoldings together.)
- --
- -- NB: because of this special case, (map (:) ys) turns into
- -- (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
- -- in core-to-stg. The top-level defn for (:) is never used.
- -- This is somewhat of a bore, but I'm currently leaving it
- -- as is, so that there still is a top level curried (:) for
- -- the interpreter to call.
-
- | otherwise
- = mkLams all_tyvars $ mkLams dict_args $
- mkLams ex_dict_args $ mkLams id_args $
- foldr mk_case con_app
- (zip (ex_dict_args++id_args) strict_marks) i3 []
-
- con_app i rep_ids = mkApps (Var work_id)
- (map varToCoreExpr (all_tyvars ++ reverse rep_ids))