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, augmentId,
24 nilDataCon, consDataCon, mkListTy, mkFunTy,
25 unpackCStringAppendId, unpackCStringFoldrId,
28 import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate )
29 import BasicLit ( BasicLit(..) )
30 import CmdLineOpts ( SimplifierSwitch(..), switchIsOn, SwitchResult )
33 import Maybes ( Maybe(..), maybeToBool )
43 %************************************************************************
45 \subsection{Types, etc., for magic-unfolding functions}
47 %************************************************************************
50 data MagicUnfoldingFun
51 = MUF ( SimplEnv -- state of play in simplifier...
52 -- (note: we can get simplifier switches
54 -> [PlainCoreArg] -- arguments
55 -> SmplM (Maybe PlainCoreExpr))
56 -- Just result, or Nothing
59 Give us a string tag, we'll give you back the corresponding MUF.
61 mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun
63 mkMagicUnfoldingFun tag
64 = assoc ("mkMagicUnfoldingFun:" ++ _UNPK_ tag) magic_UFs_table tag
67 Give us an MUF and stuff to apply it to, and we'll give you back the
70 applyMagicUnfoldingFun
74 -> SmplM (Maybe PlainCoreExpr)
76 applyMagicUnfoldingFun (MUF fun) env args = fun env args
79 %************************************************************************
81 \subsection{The table of actual magic unfoldings}
83 %************************************************************************
86 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
89 = [(SLIT("augment"), MUF augment_fun),
90 (SLIT("build"), MUF build_fun),
91 (SLIT("foldl"), MUF foldl_fun),
92 (SLIT("foldr"), MUF foldr_fun),
93 (SLIT("unpackFoldrPS#"), MUF unpack_foldr_fun),
94 (SLIT("unpackAppendPS#"), MUF unpack_append_fun)]
97 %************************************************************************
99 \subsubsection{Unfolding function for @append@}
101 %************************************************************************
104 -- First build, the way we express our lists.
106 build_fun :: SimplEnv
108 -> SmplM (Maybe PlainCoreExpr)
109 build_fun env [TypeArg ty,ValArg (CoVarAtom e)]
110 | switchIsSet env SimplDoInlineFoldrBuild =
113 ourCons = mkCoTyApp (CoVar consDataCon) ty
114 ourNil = mkCoTyApp (CoVar nilDataCon) ty
116 newIds [ ty `mkFunTy` (tyL `mkFunTy` tyL),
117 tyL ] `thenSmpl` \ [c,n] ->
118 returnSmpl(Just (CoLet (CoNonRec c ourCons)
119 (CoLet (CoNonRec n ourNil)
120 (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n)))))
121 -- ToDo: add `build' without an argument instance.
122 -- This is strange, because of g's type.
124 ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
129 augment_fun :: SimplEnv
131 -> SmplM (Maybe PlainCoreExpr)
133 augment_fun env [TypeArg ty,ValArg (CoVarAtom e),ValArg nil]
134 | switchIsSet env SimplDoInlineFoldrBuild =
137 ourCons = mkCoTyApp (CoVar consDataCon) ty
139 newId (ty `mkFunTy` (tyL `mkFunTy` tyL)) `thenSmpl` \ c ->
140 returnSmpl (Just (CoLet (CoNonRec c ourCons)
141 (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) nil)))
142 -- ToDo: add `build' without an argument instance.
143 -- This is strange, because of g's type.
145 ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
149 Now foldr, the way we consume lists.
152 foldr_fun :: SimplEnv
154 -> SmplM (Maybe PlainCoreExpr)
156 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
157 | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
158 = -- foldr (:) [] ==> id
159 -- this transformation is *always* benificial
160 -- cf. foldr (:) [] (build g) == g (:) []
161 -- with foldr (:) [] (build g) == build g
162 -- after unfolding build, they are the same thing.
163 tick Foldr_Cons_Nil `thenSmpl_`
164 newId (mkListTy ty1) `thenSmpl` \ x ->
165 returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
167 do_fb_red = switchIsSet env SimplDoFoldrBuild
169 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
170 | do_fb_red && isNilForm env arg_list
171 = -- foldr f z [] = z
172 -- again another short cut, helps with unroling of constant lists
173 tick Foldr_Nil `thenSmpl_`
174 returnSmpl (Just (atomToExpr arg_z))
176 | do_fb_red && arg_list_isBuildForm
177 = -- foldr k z (build g) ==> g k z
178 -- this next line *is* the foldr/build rule proper.
179 tick FoldrBuild `thenSmpl_`
180 returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
182 | do_fb_red && arg_list_isAugmentForm
183 = -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
184 -- this next line *is* the foldr/augment rule proper.
185 tick FoldrAugment `thenSmpl_`
186 newId ty2 `thenSmpl` \ v ->
188 (CoLet (CoNonRec v (applyToArgs (CoVar foldrId)
189 [TypeArg ty1,TypeArg ty2,
193 (applyToArgs (CoVar g') (TypeArg ty2:ValArg arg_k:ValArg (CoVarAtom v):rest_args))))
195 | do_fb_red && arg_list_isListForm
196 = -- foldr k z (a:b:c:rest) =
197 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
198 -- NB: 'k' is used just one by foldr, but 'f' is used many
199 -- times inside the list structure. This means that
200 -- 'f' needs to be inside a lambda, to make sure the simplifier
204 -- f a (f b (f c (foldr f z rest)))
206 -- let ele_1 = foldr f z rest
211 tick Foldr_List `thenSmpl_`
213 ty1 `mkFunTy` (ty2 `mkFunTy` ty2) :
214 take (length the_list) (repeat ty2)
215 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
219 (applyToArgs (CoVar foldrId)
220 [TypeArg ty1,TypeArg ty2,
221 ValArg (CoVarAtom f_id),
224 --ToDo: look for a zipWith that checks for the same length of a 3 lists
225 rest_binds = zipWith3
226 (\ e v e' -> CoNonRec e (mkRhs v e'))
228 (reverse (tail the_list))
229 (init (ele_id1:ele_ids))
230 mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e)
233 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
234 (fst_bind:rest_binds)
236 returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
237 (ValArg arg_k:rest_args)))
242 | do_fb_red && arg_list_isStringForm -- ok, its a string!
243 -- foldr f z "foo" => unpackFoldrPS# f z "foo"#
244 = tick Str_FoldrStr `thenSmpl_`
245 returnSmpl (Just (applyToArgs (CoVar unpackCStringFoldrId)
247 ValArg (CoLitAtom (MachStr str_val)):
252 do_fb_red = switchIsSet env SimplDoFoldrBuild
254 arg_list_isStringForm = maybeToBool stringForm
255 stringForm = getStringForm env arg_list
256 (Just str_val) = stringForm
258 arg_list_isBuildForm = maybeToBool buildForm
259 buildForm = getBuildForm env arg_list
262 arg_list_isAugmentForm = maybeToBool augmentForm
263 augmentForm = getAugmentForm env arg_list
264 (Just (g',h)) = augmentForm
266 arg_list_isListForm = maybeToBool listForm
267 listForm = getListForm env arg_list
268 (Just (the_list,the_tl)) = listForm
270 arg_list_isAppendForm = maybeToBool appendForm
271 appendForm = getAppendForm env arg_list
272 (Just (xs,ys)) = appendForm
275 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
276 | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
277 = -- foldr (:) z xs = xs ++ z
278 tick Foldr_Cons `thenSmpl_`
279 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
280 returnSmpl (Just (applyToArgs
281 (CoLam [z,x] (applyToArgs
284 ValArg (CoVarAtom x),
285 ValArg (CoVarAtom z)]))
287 | doing_inlining && (isInterestingArg env arg_k
288 || isConsFun env arg_k)
294 -- (a:b) -> f a (h b)
298 -- tick FoldrInline `thenSmpl_`
301 mkListTy ty1, -- b :: [t1]
303 mkListTy ty1, -- x :: t1
304 mkListTy ty1 `mkFunTy` ty2,
306 ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
310 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
312 h_rhs = (CoLam [x] (CoCase (CoVar x)
314 [(nilDataCon,[],atomToExpr (CoVarAtom z)),
315 (consDataCon,[a,b],body)]
317 body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
318 (CoApp (CoApp (atomToExpr (CoVarAtom f))
325 (CoLet (CoRec [(h,h_rhs)])
326 (CoApp (CoVar h) (CoVarAtom xs))))
327 (ValArg arg_k:rest_args)))
329 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
330 dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
331 foldr_fun _ _ = returnSmpl Nothing
333 isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
334 isConsFun env (CoVarAtom v) =
335 case lookupUnfolding env v of
336 GeneralForm _ _ (CoLam [(x,_),(y,_)]
337 (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _
338 | con == consDataCon && x==x' && y==y'
339 -> ASSERT ( length tys == 1 ) True
341 isConsFun env _ = False
343 isNilForm :: SimplEnv -> PlainCoreAtom -> Bool
344 isNilForm env (CoVarAtom v) =
345 case lookupUnfolding env v of
346 GeneralForm _ _ (CoTyApp (CoVar id) _) _
347 | id == nilDataCon -> True
348 ConstructorForm id _ _
349 | id == nilDataCon -> True
350 LiteralForm (NoRepStr s) | _NULL_ s -> True
352 isNilForm env _ = False
354 getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
355 getBuildForm env (CoVarAtom v) =
356 case lookupUnfolding env v of
357 GeneralForm False _ _ _ -> Nothing
358 -- not allowed to inline :-(
359 GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
360 | bld == buildId -> Just g
361 GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
363 | bld == augmentId && isNilForm env h -> Just g
365 getBuildForm env _ = Nothing
369 getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom)
370 getAugmentForm env (CoVarAtom v) =
371 case lookupUnfolding env v of
372 GeneralForm False _ _ _ -> Nothing
373 -- not allowed to inline :-(
374 GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
376 | bld == augmentId -> Just (g,h)
378 getAugmentForm env _ = Nothing
380 getStringForm :: SimplEnv -> PlainCoreAtom -> Maybe FAST_STRING
381 getStringForm env (CoLitAtom (NoRepStr str)) = Just str
382 getStringForm env _ = Nothing
385 getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
386 getAppendForm env (CoVarAtom v) =
387 case lookupUnfolding env v of
388 GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
389 GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _
390 | fld == foldrId && isConsFun env con -> Just (xs,ys)
392 getAppendForm env _ = Nothing
396 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
397 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
403 -> Maybe ([PlainCoreAtom],PlainCoreAtom)
404 getListForm env (CoVarAtom v) =
405 case lookupUnfolding env v of
406 ConstructorForm id _ [head,tail]
407 | id == consDataCon ->
408 case getListForm env tail of
409 Nothing -> Just ([head],tail)
410 Just (lst,new_tail) -> Just (head:lst,new_tail)
412 getListForm env _ = Nothing
414 isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool
415 isInterestingArg env (CoVarAtom v) =
416 case lookupUnfolding env v of
417 GeneralForm False _ _ UnfoldNever -> False
418 GeneralForm _ _ exp guide -> True
420 isInterestingArg env _ = False
422 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
423 | do_fb_red && isNilForm env arg_list
424 = -- foldl f z [] = z
425 -- again another short cut, helps with unroling of constant lists
426 tick Foldl_Nil `thenSmpl_`
427 returnSmpl (Just (atomToExpr arg_z))
429 | do_fb_red && arg_list_isBuildForm
430 = -- foldl t1 t2 k z (build t3 g) ==>
431 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
432 -- n {- INLINE -} = \ a -> a
434 -- this next line *is* the foldr/build rule proper.
435 tick FoldlBuild `thenSmpl_`
436 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
439 {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
440 {- pre_n -} ty1 `mkFunTy` ty1,
442 {- g' -} ty1 `mkFunTy` ty1,
446 ] `thenSmpl` \ [pre_c,
455 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
456 c_rhs = CoLam [b,g',a]
457 (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
458 (CoApp (CoVar g') (CoVarAtom t)))
459 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
460 n_rhs = CoLam [a'] (CoVar a')
462 returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs)
463 (applyToArgs (CoVar g)
464 (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n)
465 :ValArg arg_z:rest_args)))))
467 | do_fb_red && arg_list_isAugmentForm
468 = -- foldl t1 t2 k z (augment t3 g h) ==>
469 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
470 -- n {- INLINE -} = \ a -> a
471 -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
473 -- this next line *is* the foldr/build rule proper.
474 tick FoldlAugment `thenSmpl_`
475 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
478 {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
479 {- pre_n -} ty1 `mkFunTy` ty1,
480 {- pre_r -} ty1 `mkFunTy` ty1,
482 {- g_ -} ty1 `mkFunTy` ty1,
486 ] `thenSmpl` \ [pre_c,
496 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
497 c_rhs = CoLam [b,g_,a]
498 (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
499 (CoApp (CoVar g_) (CoVarAtom t)))
500 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
501 n_rhs = CoLam [a'] (CoVar a')
502 r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
503 r_rhs = applyToArgs (CoVar foldrId)
504 [TypeArg ty2,TypeArg (ty1 `mkFunTy` ty1),
505 ValArg (CoVarAtom c),
506 ValArg (CoVarAtom n),
509 returnSmpl (Just (CoLet (CoNonRec c c_rhs)
510 (CoLet (CoNonRec n n_rhs)
511 (CoLet (CoNonRec r r_rhs)
512 (applyToArgs (CoVar g')
513 (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom r)
514 :ValArg arg_z:rest_args))))))
516 | do_fb_red && arg_list_isListForm
517 = -- foldl k z (a:b:c:rest) =
518 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
519 -- NB: 'k' is used just one by foldr, but 'f' is used many
520 -- times inside the list structure. This means that
521 -- 'f' needs to be inside a lambda, to make sure the simplifier
525 -- foldl f (f (f (f z a) b) c) rest
526 -- f a (f b (f c (foldr f z rest)))
531 -- in foldl f ele_3 rest
533 tick Foldl_List `thenSmpl_`
535 ty1 `mkFunTy` (ty2 `mkFunTy` ty1) :
536 take (length the_list) (repeat ty1)
537 ) `thenSmpl` \ (f_id:ele_ids) ->
539 --ToDo: look for a zipWith that checks for the same length of a 3 lists
540 rest_binds = zipWith3
541 (\ e v e' -> CoNonRec e (mkRhs v e'))
543 the_list -- :: [PlainCoreAtom]
544 (init (arg_z:map CoVarAtom ele_ids)) -- :: [PlainCoreAtom]
545 mkRhs v e = CoApp (CoApp (CoVar f_id) e) v
547 last_bind = applyToArgs (CoVar foldlId)
548 [TypeArg ty1,TypeArg ty2,
549 ValArg (CoVarAtom f_id),
550 ValArg (CoVarAtom (last ele_ids)),
557 returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
558 (ValArg arg_k:rest_args)))
561 do_fb_red = switchIsSet env SimplDoFoldrBuild
563 arg_list_isAugmentForm = maybeToBool augmentForm
564 augmentForm = getAugmentForm env arg_list
565 (Just (g',h)) = augmentForm
567 arg_list_isBuildForm = maybeToBool buildForm
568 buildForm = getBuildForm env arg_list
571 arg_list_isListForm = maybeToBool listForm
572 listForm = getListForm env arg_list
573 (Just (the_list,the_tl)) = listForm
576 arg_list_isAppendForm = maybeToBool appendForm
577 appendForm = getAppendForm env arg_list
578 (Just (xs,ys)) = appendForm
581 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
582 | doing_inlining && (isInterestingArg env arg_k
583 || isConsFun env arg_k)
589 -- (a:b) -> h b (f r a)
593 -- tick FoldrInline `thenSmpl_`
596 mkListTy ty2, -- b :: [t1]
598 mkListTy ty2, -- x :: t1
599 mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1),
600 -- h :: [t2] -> t1 -> t1
601 ty1 `mkFunTy` (ty2 `mkFunTy` ty1),
606 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
608 h_rhs = (CoLam [x,r] (CoCase (CoVar x)
610 [(nilDataCon,[],atomToExpr (CoVarAtom r)),
611 (consDataCon,[a,b],body)]
613 body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r))
615 (CoApp (CoApp (atomToExpr (CoVarAtom h))
622 (CoLet (CoRec [(h,h_rhs)])
623 (CoApp (CoApp (CoVar h) (CoVarAtom xs))
625 (ValArg arg_k:rest_args)))
627 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
629 foldl_fun env _ = returnSmpl Nothing
635 -- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
637 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
638 | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
639 = tick Str_UnpackCons `thenSmpl_`
640 returnSmpl (Just (applyToArgs (CoVar unpackCStringAppendId)
643 unpack_foldr_fun env _ = returnSmpl Nothing
645 unpack_append_fun env
646 [ValArg (CoLitAtom (MachStr str_val)),ValArg arg_z]
647 | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
648 = tick Str_UnpackNil `thenSmpl_`
649 returnSmpl (Just (CoLit (NoRepStr str_val)))
650 unpack_append_fun env _ = returnSmpl Nothing