- unfolding = mkTopUnfolding (Note InlineMe con_rhs)
- -- The dictionary constructors of a class don't get a binding,
- -- but they are always saturated, so they should always be inlined.
-
- (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
- = dataConSig data_con
- rep_arg_tys = dataConRawArgTys data_con
- all_tyvars = tyvars ++ ex_tyvars
-
- dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
- ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
-
- n_dicts = length dict_tys
- n_ex_dicts = length ex_dict_tys
- n_id_args = length orig_arg_tys
- n_rep_args = length rep_arg_tys
-
- result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
-
- mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
- (dict_args, i1) = mkLocals 1 n_dicts dict_tys
- (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys
- (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys
-
- (id_arg1:_) = id_args -- Used for newtype only
- strict_marks = dataConStrictMarks data_con
-
- con_app i rep_ids
- | isNewTyCon tycon
- = ASSERT( length orig_arg_tys == 1 )
- Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
- | otherwise
- = mkConApp data_con
- (map Type (mkTyVarTys all_tyvars) ++
- map Var (reverse rep_ids))
-
- con_rhs = mkLams all_tyvars $ mkLams dict_args $
- mkLams ex_dict_args $ mkLams id_args $
- foldr mk_case con_app
+ wrap_id = mkId (dataConName data_con) wrap_ty info
+ work_id = dataConId data_con
+
+ info = mkIdInfo (DataConWrapId data_con)
+ `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
+ `setCafInfo` NoCafRefs
+ -- The wrapper Id ends up in STG code as an argument,
+ -- sometimes before its definition, so we want to
+ -- signal that it has no CAFs
+
+ 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