2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[MagicUFs]{Magic unfoldings that the simplifier knows about}
7 #include "HsVersions.h"
10 MagicUnfoldingFun, -- absolutely abstract
13 applyMagicUnfoldingFun,
15 CoreArg, PlainCoreArg(..), CoreAtom, PlainCoreAtom(..),
16 CoreExpr, PlainCoreExpr(..), Id, Maybe, SimplEnv,
17 SplitUniqSupply, TickType, UniType,
21 IMPORT_Trace -- ToDo: not sure why this is being used
23 import AbsPrel ( foldlId, foldrId, buildId,
24 nilDataCon, consDataCon, mkListTy, mkFunTy,
27 import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate )
28 import BasicLit ( BasicLit(..) )
29 import CmdLineOpts ( SimplifierSwitch(..), switchIsOn, SwitchResult )
32 import Maybes ( Maybe(..), maybeToBool )
42 %************************************************************************
44 \subsection{Types, etc., for magic-unfolding functions}
46 %************************************************************************
49 data MagicUnfoldingFun
50 = MUF ( SimplEnv -- state of play in simplifier...
51 -- (note: we can get simplifier switches
53 -> [PlainCoreArg] -- arguments
54 -> SmplM (Maybe PlainCoreExpr))
55 -- Just result, or Nothing
58 Give us a string tag, we'll give you back the corresponding MUF.
60 mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun
62 mkMagicUnfoldingFun tag
63 = assoc ("mkMagicUnfoldingFun:" ++ _UNPK_ tag) magic_UFs_table tag
66 Give us an MUF and stuff to apply it to, and we'll give you back the
69 applyMagicUnfoldingFun
73 -> SmplM (Maybe PlainCoreExpr)
75 applyMagicUnfoldingFun (MUF fun) env args = fun env args
78 %************************************************************************
80 \subsection{The table of actual magic unfoldings}
82 %************************************************************************
85 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
88 = [(SLIT("build"), MUF build_fun),
89 (SLIT("foldl"), MUF foldl_fun),
90 (SLIT("foldr"), MUF foldr_fun) ]
93 %************************************************************************
95 \subsubsection{Unfolding function for @append@}
97 %************************************************************************
100 -- First build, the way we express our lists.
102 build_fun :: SimplEnv
104 -> SmplM (Maybe PlainCoreExpr)
105 build_fun env [TypeArg ty,ValArg (CoVarAtom e)]
106 | switchIsSet env SimplDoInlineFoldrBuild =
109 ourCons = mkCoTyApp (CoVar consDataCon) ty
110 ourNil = mkCoTyApp (CoVar nilDataCon) ty
112 newIds [ ty `mkFunTy` (tyL `mkFunTy` tyL),
113 tyL ] `thenSmpl` \ [c,n] ->
114 returnSmpl(Just (CoLet (CoNonRec c ourCons)
115 (CoLet (CoNonRec n ourNil)
116 (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n)))))
117 -- ToDo: add `build' without an argument instance.
118 -- This is strange, because of g's type.
120 ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
123 -- Now foldr, the way we consume lists.
125 foldr_fun :: SimplEnv
127 -> SmplM (Maybe PlainCoreExpr)
130 | trace "HEHJDHF!" False = error "NEVER"
132 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
133 | isConsFun env arg_k && isNilForm env arg_z
134 = -- foldr (:) [] ==> id
135 -- this transformation is *always* benificial
136 -- cf. foldr (:) [] (build g) == g (:) []
137 -- with foldr (:) [] (build g) == build g
138 -- after unfolding build, they are the same thing.
139 tick FoldrConsNil `thenSmpl_`
140 newId (mkListTy ty1) `thenSmpl` \ x ->
141 returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
143 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
144 | do_fb_red && isNilForm env arg_list
145 = -- foldr f z [] = z
146 -- again another short cut, helps with unroling of constant lists
147 tick Foldr_Nil `thenSmpl_`
148 returnSmpl (Just (atomToExpr arg_z))
150 | do_fb_red && arg_list_isBuildForm
151 = -- foldr k z (build g) ==> g k z
152 -- this next line *is* the foldr/build rule proper.
153 tick FoldrBuild `thenSmpl_`
154 returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
156 | do_fb_red && arg_list_isAppendForm
157 = -- foldr k z (foldr (:) ys xs) <args> ==> foldr k (foldr k z ys) xs <args>
158 -- this unfolds foldr one into foldr
159 tick FoldrFoldr `thenSmpl_`
160 newId ty2 `thenSmpl` \ other_foldr ->
162 inner_foldr = applyToArgs (CoVar foldrId)
163 [TypeArg ty1,TypeArg ty2,
164 ValArg arg_k,ValArg arg_z,ValArg ys]
165 outer_foldr = applyToArgs (CoVar foldrId)
166 ([TypeArg ty1,TypeArg ty2,
167 ValArg arg_k,ValArg (CoVarAtom other_foldr),ValArg xs]
169 in returnSmpl (Just (CoLet (CoNonRec other_foldr inner_foldr) outer_foldr))
171 | do_fb_red && arg_list_isListForm
172 = -- foldr k z (a:b:c:rest) =
173 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
174 -- NB: 'k' is used just one by foldr, but 'f' is used many
175 -- times inside the list structure. This means that
176 -- 'f' needs to be inside a lambda, to make sure the simplifier
180 -- f a (f b (f c (foldr f z rest)))
182 -- let ele_1 = foldr f z rest
187 tick Foldr_List `thenSmpl_`
189 ty1 `mkFunTy` (ty2 `mkFunTy` ty2) :
190 take (length the_list) (repeat ty2)
191 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
195 (applyToArgs (CoVar foldrId)
196 [TypeArg ty1,TypeArg ty2,
197 ValArg (CoVarAtom f_id),
200 --ToDo: look for a zipWith that checks for the same length of a 3 lists
201 rest_binds = zipWith3
202 (\ e v e' -> CoNonRec e (mkRhs v e'))
204 (reverse (tail the_list))
205 (init (ele_id1:ele_ids))
206 mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e)
209 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
210 (fst_bind:rest_binds)
212 returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
213 (ValArg arg_k:rest_args)))
216 do_fb_red = switchIsSet env SimplDoFoldrBuild
218 arg_list_isBuildForm = maybeToBool buildForm
219 buildForm = getBuildForm env arg_list
222 arg_list_isListForm = maybeToBool listForm
223 listForm = getListForm env arg_list
224 (Just (the_list,the_tl)) = listForm
226 arg_list_isAppendForm = maybeToBool appendForm
227 appendForm = getAppendForm env arg_list
228 (Just (xs,ys)) = appendForm
230 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
232 | doing_inlining && isConsFun env arg_k
233 = -- foldr (:) z xs = xs ++ z
234 tick FoldrCons `thenSmpl_`
235 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
236 returnSmpl (Just (applyToArgs
237 (CoLam [z,x] (applyToArgs
240 ValArg (CoVarAtom x),
241 ValArg (CoVarAtom z)]))
244 | doing_inlining && (isInterestingArg env arg_k
245 || isConsFun env arg_k)
251 -- (a:b) -> f a (h b)
255 tick FoldrInline `thenSmpl_`
258 mkListTy ty1, -- b :: [t1]
260 mkListTy ty1, -- x :: t1
261 mkListTy ty1 `mkFunTy` ty2,
263 ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
267 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
269 h_rhs = (CoLam [x] (CoCase (CoVar x)
271 [(nilDataCon,[],atomToExpr (CoVarAtom z)),
272 (consDataCon,[a,b],body)]
274 body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
275 (CoApp (CoApp (atomToExpr (CoVarAtom f))
282 (CoLet (CoRec [(h,h_rhs)])
283 (CoApp (CoVar h) (CoVarAtom xs))))
284 (ValArg arg_k:rest_args)))
286 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
287 foldr_fun _ _ = returnSmpl Nothing
289 isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
290 isConsFun env (CoVarAtom v) =
291 case lookupUnfolding env v of
292 GeneralForm _ _ (CoLam [(x,_),(y,_)]
293 (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _
294 | con == consDataCon && x==x' && y==y'
295 -> ASSERT ( length tys == 1 ) True
297 isConsFun env _ = False
299 isNilForm :: SimplEnv -> PlainCoreAtom -> Bool
300 isNilForm env (CoVarAtom v) =
301 case lookupUnfolding env v of
302 GeneralForm _ _ (CoTyApp (CoVar id) _) _
303 | id == nilDataCon -> True
304 ConstructorForm id _ _
305 | id == nilDataCon -> True
306 LiteralForm (NoRepStr s) | _NULL_ s -> True
308 isNilForm env _ = False
310 getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
311 getBuildForm env (CoVarAtom v) =
312 case lookupUnfolding env v of
313 GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
314 GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
315 | bld == buildId -> Just g
317 getBuildForm env _ = Nothing
319 getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
320 getAppendForm env (CoVarAtom v) =
321 case lookupUnfolding env v of
322 GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
323 GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _
324 | fld == foldrId && isConsFun env con -> Just (xs,ys)
326 getAppendForm env _ = Nothing
329 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
330 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
336 -> Maybe ([PlainCoreAtom],PlainCoreAtom)
337 getListForm env (CoVarAtom v) =
338 case lookupUnfolding env v of
339 ConstructorForm id _ [head,tail]
340 | id == consDataCon ->
341 case getListForm env tail of
342 Nothing -> Just ([head],tail)
343 Just (lst,new_tail) -> Just (head:lst,new_tail)
345 getListForm env _ = Nothing
347 isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool
348 isInterestingArg env (CoVarAtom v) =
349 case lookupUnfolding env v of
350 GeneralForm False _ _ UnfoldNever -> False
351 GeneralForm _ _ exp guide -> True
353 isInterestingArg env _ = False
355 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
356 | do_fb_red && isNilForm env arg_list
357 = -- foldl f z [] = z
358 -- again another short cut, helps with unroling of constant lists
359 tick Foldr_Nil `thenSmpl_`
360 returnSmpl (Just (atomToExpr arg_z))
362 | do_fb_red && arg_list_isBuildForm
363 = -- foldl t1 t2 k z (build t3 g) ==>
364 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
365 -- n {- INLINE -} = \ a -> a
367 -- this next line *is* the foldr/build rule proper.
368 tick FoldrBuild `thenSmpl_`
369 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
372 {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
373 {- pre_n -} ty1 `mkFunTy` ty1,
375 {- g' -} ty1 `mkFunTy` ty1,
379 ] `thenSmpl` \ [pre_c,
388 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
389 c_rhs = CoLam [b,g',a]
390 (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
391 (CoApp (CoVar g') (CoVarAtom t)))
392 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
393 n_rhs = CoLam [a'] (CoVar a')
395 returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs)
396 (applyToArgs (CoVar g)
397 (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n)
398 :ValArg arg_z:rest_args)))))
401 | do_fb_red && arg_list_isAppendForm
402 = -- foldl k z (foldr (:) ys xs) <args> ==> foldl k (foldl k z xs) ys <args>
403 -- be caseful with for order of xs / ys
404 tick FoldrFoldr `thenSmpl_`
405 newId ty1 `thenSmpl` \ other_foldl ->
407 inner_foldl = applyToArgs (CoVar foldlId)
408 [TypeArg ty1,TypeArg ty2,
409 ValArg arg_k,ValArg arg_z,ValArg xs]
410 outer_foldl = applyToArgs (CoVar foldlId)
411 ([TypeArg ty1,TypeArg ty2,
412 ValArg arg_k,ValArg (CoVarAtom other_foldl),ValArg ys]
414 in returnSmpl (Just (CoLet (CoNonRec other_foldl inner_foldl) outer_foldl))
416 | do_fb_red && arg_list_isListForm
417 = -- foldl k z (a:b:c:rest) =
418 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
419 -- NB: 'k' is used just one by foldr, but 'f' is used many
420 -- times inside the list structure. This means that
421 -- 'f' needs to be inside a lambda, to make sure the simplifier
425 -- foldl f (f (f (f z a) b) c) rest
426 -- f a (f b (f c (foldr f z rest)))
431 -- in foldl f ele_3 rest
433 tick Foldr_List `thenSmpl_`
435 ty1 `mkFunTy` (ty2 `mkFunTy` ty1) :
436 take (length the_list) (repeat ty1)
437 ) `thenSmpl` \ (f_id:ele_ids) ->
439 --ToDo: look for a zipWith that checks for the same length of a 3 lists
440 rest_binds = zipWith3
441 (\ e v e' -> CoNonRec e (mkRhs v e'))
443 the_list -- :: [PlainCoreAtom]
444 (init (arg_z:map CoVarAtom ele_ids)) -- :: [PlainCoreAtom]
445 mkRhs v e = CoApp (CoApp (CoVar f_id) e) v
447 last_bind = applyToArgs (CoVar foldlId)
448 [TypeArg ty1,TypeArg ty2,
449 ValArg (CoVarAtom f_id),
450 ValArg (CoVarAtom (last ele_ids)),
457 returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
458 (ValArg arg_k:rest_args)))
461 do_fb_red = switchIsSet env SimplDoFoldrBuild
463 arg_list_isBuildForm = maybeToBool buildForm
464 buildForm = getBuildForm env arg_list
467 arg_list_isListForm = maybeToBool listForm
468 listForm = getListForm env arg_list
469 (Just (the_list,the_tl)) = listForm
471 arg_list_isAppendForm = maybeToBool appendForm
472 appendForm = getAppendForm env arg_list
473 (Just (xs,ys)) = appendForm
475 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
476 | doing_inlining && (isInterestingArg env arg_k
477 || isConsFun env arg_k)
483 -- (a:b) -> h b (f r a)
487 tick FoldrInline `thenSmpl_`
490 mkListTy ty2, -- b :: [t1]
492 mkListTy ty2, -- x :: t1
493 mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1),
494 -- h :: [t2] -> t1 -> t1
495 ty1 `mkFunTy` (ty2 `mkFunTy` ty1),
500 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
502 h_rhs = (CoLam [x,r] (CoCase (CoVar x)
504 [(nilDataCon,[],atomToExpr (CoVarAtom r)),
505 (consDataCon,[a,b],body)]
507 body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r))
509 (CoApp (CoApp (atomToExpr (CoVarAtom h))
516 (CoLet (CoRec [(h,h_rhs)])
517 (CoApp (CoApp (CoVar h) (CoVarAtom xs))
519 (ValArg arg_k:rest_args)))
521 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
523 foldl_fun env _ = returnSmpl Nothing