- (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
- is_newtype = isNewTyCon tycon
- all_tyvars = tyvars ++ ex_tyvars
- work_id = dataConWorkId data_con
-
- common_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
- `setArityInfo` arity
- -- It's important to specify the arity, so that partial
- -- applications are treated as values
-
- info | is_newtype = common_info `setUnfoldingInfo` newtype_unf
- | otherwise = common_info `setUnfoldingInfo` data_unf
- `setAllStrictnessInfo` Just wrap_sig
-
- wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
- res_info = strictSigResInfo (idNewStrictness work_id)
- arg_dmds = map mk_dmd strict_marks
+ (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
+
+ dict_tys = mkPredTys theta
+ all_arg_tys = dict_tys ++ orig_arg_tys
+ result_ty = mkTyConApp tycon res_tys
+
+ wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
+ -- We used to include the stupid theta in the wrapper's args
+ -- but now we don't. Instead the type checker just injects these
+ -- extra constraints where necessary.
+
+ ----------- Worker (algebraic data types only) --------------
+ wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
+ (dataConRepType data_con) wkr_info
+
+ wkr_arity = dataConRepArity data_con
+ wkr_info = noCafIdInfo
+ `setArityInfo` wkr_arity
+ `setAllStrictnessInfo` Just wkr_sig
+ `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
+ -- even if arity = 0
+
+ wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+ -- Notice that we do *not* say the worker is strict
+ -- even if the data constructor is declared strict
+ -- e.g. data T = MkT !(Int,Int)
+ -- Why? Because the *wrapper* is strict (and its unfolding has case
+ -- expresssions that do the evals) but the *worker* itself is not.
+ -- If we pretend it is strict then when we see
+ -- case x of y -> $wMkT y
+ -- the simplifier thinks that y is "sure to be evaluated" (because
+ -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
+ --
+ -- When the simplifer sees a pattern
+ -- case e of MkT x -> ...
+ -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+ -- but that's fine... dataConRepStrictness comes from the data con
+ -- not from the worker Id.
+
+ cpr_info | isProductTyCon tycon &&
+ isDataTyCon tycon &&
+ wkr_arity > 0 &&
+ wkr_arity <= mAX_CPR_SIZE = retCPR
+ | otherwise = TopRes
+ -- RetCPR is only true for products that are real data types;
+ -- that is, not unboxed tuples or [non-recursive] newtypes
+
+ ----------- Wrappers for newtypes --------------
+ nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
+ nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
+ `setArityInfo` 1 -- Arity 1
+ `setUnfoldingInfo` newtype_unf
+ newtype_unf = ASSERT( isVanillaDataCon data_con &&
+ isSingleton orig_arg_tys )
+ -- No existentials on a newtype, but it can have a context
+ -- e.g. newtype Eq a => T a = MkT (...)
+ mkTopUnfolding $ Note InlineMe $
+ mkLams tyvars $ Lam id_arg1 $
+ mkNewTypeBody tycon result_ty (Var id_arg1)
+
+ id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
+
+ ----------- Wrappers for algebraic data types --------------
+ alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
+ alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
+ `setArityInfo` alg_arity
+ -- It's important to specify the arity, so that partial
+ -- applications are treated as values
+ `setUnfoldingInfo` alg_unf
+ `setAllStrictnessInfo` Just wrap_sig
+
+ all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
+ wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
+ arg_dmds = map mk_dmd all_strict_marks