2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
7 #include "HsVersions.h"
12 worthSplitting, setUnpackStrategy,
19 import Id ( idType, mkSysLocal, dataConArgTys, SYN_IE(Id) )
20 import IdInfo ( mkStrictnessInfo, {-??nonAbsentArgs,-} Demand(..) )
21 import PrelVals ( aBSENT_ERROR_ID, voidId )
22 import TysPrim ( voidTy )
23 import SrcLoc ( noSrcLoc )
24 import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
25 splitForAllTy, splitFunTyExpandingDicts,
26 maybeAppDataTyConExpandingDicts,
29 import TyVar ( SYN_IE(TyVar) )
30 import UniqSupply ( returnUs, thenUs, thenMaybeUs,
31 getUniques, getUnique, SYN_IE(UniqSM)
33 import Util ( zipWithEqual, zipEqual, assertPanic, panic, pprPanic )
39 %************************************************************************
41 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
43 %************************************************************************
45 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
46 an ``intermediate form'' that can later be turned into a \tr{let} or
47 \tr{case} (depending on strictness info).
52 | WwCase (CoreExpr -> CoreExpr)
53 -- the "case" will be a "strict let" of the form:
58 -- (instead of "let <blah> = rhs in body")
60 -- The expr you pass to the function is "body" (the
61 -- expression that goes "in the corner").
64 %************************************************************************
66 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
68 %************************************************************************
70 ************ WARNING ******************
71 these comments are rather out of date
72 *****************************************
74 @mkWrapperAndWorker@ is given:
77 The {\em original function} \tr{f}, of the form:
79 f = /\ tyvars -> \ args -> body
81 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
84 We use the Id \tr{f} mostly to get its type.
87 Strictness information about \tr{f}, in the form of a list of
94 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
97 Maybe @Nothing@: no worker/wrappering going on in this case. This can
98 happen (a)~if the strictness info says that there is nothing
99 interesting to do or (b)~if *any* of the argument types corresponding
100 to ``active'' arg postitions is abstract or will be to the outside
101 world (i.e., {\em this} module can see the constructors, but nobody
102 else will be able to). An ``active'' arg position is one which the
103 wrapper has to unpack. An importing module can't do this unpacking,
104 so it simply has to give up and call the wrapper only.
107 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
109 The @wrapper_Id@ is just the one that was passed in, with its
110 strictness IdInfo updated.
113 The \tr{body} of the original function may not be given (i.e., it's
114 BOTTOM), in which case you'd jolly well better not tug on the
117 Here's an example. The original function is:
119 g :: forall a . Int -> [a] -> a
121 g = /\ a -> \ x ys ->
127 From this, we want to produce:
129 -- wrapper (an unfolding)
130 g :: forall a . Int -> [a] -> a
132 g = /\ a -> \ x ys ->
134 I# x# -> g.wrk a x# ys
135 -- call the worker; don't forget the type args!
138 g.wrk :: forall a . Int# -> [a] -> a
140 g.wrk = /\ a -> \ x# ys ->
144 case x of -- note: body of g moved intact
149 Something we have to be careful about: Here's an example:
151 -- "f" strictness: U(P)U(P)
152 f (I# a) (I# b) = a +# b
154 g = f -- "g" strictness same as "f"
156 \tr{f} will get a worker all nice and friendly-like; that's good.
157 {\em But we don't want a worker for \tr{g}}, even though it has the
158 same strictness as \tr{f}. Doing so could break laziness, at best.
160 Consequently, we insist that the number of strictness-info items is
161 exactly the same as the number of lambda-bound arguments. (This is
162 probably slightly paranoid, but OK in practice.) If it isn't the
163 same, we ``revise'' the strictness info, so that we won't propagate
164 the unusable strictness-info into the interfaces.
167 %************************************************************************
169 \subsection{Functions over Demands}
171 %************************************************************************
174 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
177 setUnpackStrategy :: [Demand] -> [Demand]
179 = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
181 go :: Int -- Max number of args available for sub-components of [Demand]
183 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
185 go n (WwUnpack _ cs : ds) | n' >= 0
186 = WwUnpack True cs' `cons` go n'' ds
188 = WwUnpack False cs `cons` go n ds
190 n' = n + 1 - nonAbsentArgs cs
191 -- Add one because we don't pass the top-level arg any more
192 -- Delete # of non-absent args to which we'll now be committed
195 go n (d:ds) = d `cons` go n ds
198 cons d (n,ds) = (n, d:ds)
200 nonAbsentArgs :: [Demand] -> Int
202 nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
203 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
205 worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function
206 worthSplitting [] = False
207 worthSplitting (WwLazy True : ds) = True -- Absent arg
208 worthSplitting (WwUnpack True _ : ds) = True -- Arg to unpack
209 worthSplitting (d : ds) = worthSplitting ds
211 allAbsent :: [Demand] -> Bool
212 allAbsent (WwLazy True : ds) = allAbsent ds
213 allAbsent (WwUnpack True cs : ds) = allAbsent cs && allAbsent ds
214 allAbsent (d : ds) = False
219 %************************************************************************
221 \subsection{The worker wrapper core}
223 %************************************************************************
225 @mkWrapper@ is called when importing a function. We have the type of
226 the function and the name of its worker, and we want to make its body (the wrapper).
229 mkWrapper :: Type -- Wrapper type
230 -> [Demand] -- Wrapper strictness info
231 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
233 mkWrapper fun_ty demands
235 n_wrap_args = length demands
237 getUniques n_wrap_args `thenUs` \ wrap_uniqs ->
239 (tyvars, tau_ty) = splitForAllTy fun_ty
240 (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty
241 wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys
242 leftover_arg_tys = drop n_wrap_args arg_tys
243 final_body_ty = mkFunTys leftover_arg_tys body_ty
245 mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) ->
249 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
252 mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
253 -> [Demand] -- Strictness info for original fn; corresp 1-1 with args
254 -> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
255 CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
256 [Demand]) -- Strictness info for worker
258 mkWwBodies tyvars args body_ty demands
259 | allAbsent demands &&
261 = -- Horrid special case. If the worker would have no arguments, and the
262 -- function returns a primitive type value, that would make the worker into
263 -- an unboxed value. We box it by passing a dummy void argument, thus:
265 -- f = /\abc. \xyz. fw abc void
266 -- fw = /\abc. \v. body
268 getUnique `thenUs` \ void_arg_uniq ->
270 void_arg = mk_ww_local void_arg_uniq voidTy
272 returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
273 \ body -> mkLam tyvars [void_arg] body,
276 mkWwBodies tyvars args body_ty demands
279 args_w_demands = zipEqual "mkWwBodies" args demands
281 mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
283 (work_args, work_demands) = unzip work_args_w_demands
285 returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
286 \ body -> mkLam tyvars work_args (work_fn body),
292 mkWW :: [(Id,Demand)]
293 -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
294 -- and without its lambdas
295 [(Id,Demand)], -- Worker args and their demand infos
296 CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
301 = returnUs (\ wrapper_body -> wrapper_body,
303 \ worker_body -> worker_body)
307 mkWW ((arg,WwLazy True) : ds)
308 = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
309 returnUs (\ wrapper_body -> wrap_fn wrapper_body,
311 \ worker_body -> mk_absent_let arg (work_fn worker_body))
315 mkWW ((arg,WwUnpack True cs) : ds)
316 = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
318 unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
319 unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
321 mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
322 returnUs (\ wrapper_body -> mk_unpk_case arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
324 \ worker_body -> work_fn (mk_pk_let arg data_con tycon_arg_tys unpk_args worker_body))
326 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
327 (arg_tycon, tycon_arg_tys, data_con)
328 = case (maybeAppDataTyConExpandingDicts (idType arg)) of
330 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
331 -- The main event: a single-constructor data type
332 (arg_tycon, tycon_arg_tys, data_con)
334 Just (_, _, data_cons) -> pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr PprDebug arg) <+> (ppr PprDebug (idType arg)))
335 Nothing -> panic "mk_ww_arg_processing: not datatype"
339 mkWW ((arg,other_demand) : ds)
340 = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
341 returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
342 (arg,other_demand) : worker_args,
347 %************************************************************************
349 \subsection{Utilities}
351 %************************************************************************
355 mk_absent_let arg body
356 | not (isPrimType arg_ty)
357 = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
359 = panic "WwLib: haven't done mk_absent_let for primitives yet"
363 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
365 (AlgAlts [(boxing_con, unpk_args, body)]
369 mk_pk_let arg boxing_con con_tys unpk_args body
370 = Let (NonRec arg (Con boxing_con con_args)) body
372 con_args = map TyArg con_tys ++ map VarArg unpk_args
375 = mkSysLocal SLIT("ww") uniq ty noSrcLoc