- unfolding = mkUnfolding con_rhs
-
- (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
-
- dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
- con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
- n_dicts = length dict_tys
- result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
-
- locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
- data_args = drop n_dicts locals
- (data_arg1:_) = data_args -- Used for newtype only
- strict_marks = dataConStrictMarks con_id
- strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
- -- NB: we can't call mkTemplateLocals twice, because it
- -- always starts from the same unique.
-
- con_app | isNewTyCon tycon
- = ASSERT( length arg_tys == 1)
- Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
- | otherwise
- = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
-
- con_rhs = mkTyLam tyvars $
- mkValLam locals $
- foldr mk_case con_app strict_args
-
- mk_case arg body | isUnpointedType (idType arg)
- = body -- "!" on unboxed arg does nothing
- | otherwise
- = Case (Var arg) (AlgAlts [] (BindDefault arg body))
- -- This case shadows "arg" but that's fine
+ work_id = dataConWorkId data_con
+
+ info = noCafIdInfo
+ `setUnfoldingInfo` wrap_unf
+ -- The NoCaf-ness is set by noCafIdInfo
+ `setArityInfo` arity
+ -- It's important to specify the arity, so that partial
+ -- applications are treated as values
+ `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
+ mk_dmd str | isMarkedStrict str = evalDmd
+ | otherwise = lazyDmd
+ -- The Cpr info can be important inside INLINE rhss, where the
+ -- wrapper constructor isn't inlined.
+ -- And the argument strictness can be important too; we
+ -- may not inline a contructor when it is partially applied.
+ -- For example:
+ -- data W = C !Int !Int !Int
+ -- ...(let w = C x in ...(w p q)...)...
+ -- we want to see that w is strict in its two arguments
+
+ wrap_unf | isNewTyCon tycon
+ = ASSERT( null ex_tyvars && null ex_dict_args && 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)
+
+ | not (any isMarkedStrict strict_marks)
+ = mkCompulsoryUnfolding (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). 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
+ = mkTopUnfolding $ Note InlineMe $
+ mkLams all_tyvars $
+ 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))
+
+ (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
+ all_tyvars = tyvars ++ ex_tyvars
+
+ ex_dict_tys = mkPredTys ex_theta
+ all_arg_tys = ex_dict_tys ++ orig_arg_tys
+ result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+
+ wrap_ty = mkForAllTys all_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.
+
+ mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
+ where
+ n = length tys
+
+ (ex_dict_args,i2) = mkLocals 1 ex_dict_tys
+ (id_args,i3) = mkLocals i2 orig_arg_tys
+ arity = i3-1
+ (id_arg1:_) = id_args -- Used for newtype only
+
+ strict_marks = dataConStrictMarks data_con
+
+ mk_case
+ :: (Id, StrictnessMark) -- Arg, strictness
+ -> (Int -> [Id] -> CoreExpr) -- Body
+ -> Int -- Next rep arg id
+ -> [Id] -- Rep args so far, reversed
+ -> CoreExpr
+ mk_case (arg,strict) body i rep_args
+ = case strict of
+ NotMarkedStrict -> body i (arg:rep_args)
+ MarkedStrict
+ | isUnLiftedType (idType arg) -> body i (arg:rep_args)
+ | otherwise ->
+ Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+
+ MarkedUnboxed
+ -> case splitProductType "do_unbox" (idType arg) of
+ (tycon, tycon_args, con, tys) ->
+ Case (Var arg) arg [(DataAlt con, con_args,
+ body i' (reverse con_args ++ rep_args))]
+ where
+ (con_args, i') = mkLocals i tys
projects / ghc-hetmet.git / blobdiff