2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[MagicUFs]{Magic unfoldings that the simplifier knows about}
7 #include "HsVersions.h"
10 MagicUnfoldingFun, -- absolutely abstract
13 applyMagicUnfoldingFun
17 IMPORT_DELOOPER(IdLoop) -- paranoia checking
20 import SimplEnv ( SimplEnv )
21 import SimplMonad ( SYN_IE(SmplM), SimplCount )
22 import Type ( mkFunTys )
23 import TysWiredIn ( mkListTy )
24 import Unique ( Unique{-instances-} )
25 import Util ( assoc, zipWith3Equal, nOfThem, panic )
28 %************************************************************************
30 \subsection{Types, etc., for magic-unfolding functions}
32 %************************************************************************
35 data MagicUnfoldingFun
36 = MUF ( SimplEnv -- state of play in simplifier...
37 -- (note: we can get simplifier switches
39 -> [CoreArg] -- arguments
40 -> SmplM (Maybe CoreExpr))
41 -- Just result, or Nothing
44 Give us a value's @Unique@, we'll give you back the corresponding MUF.
46 mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
48 mkMagicUnfoldingFun tag
49 = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
51 magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
54 Give us an MUF and stuff to apply it to, and we'll give you back the
57 applyMagicUnfoldingFun
61 -> SmplM (Maybe CoreExpr)
63 applyMagicUnfoldingFun (MUF fun) env args = fun env args
66 %************************************************************************
68 \subsection{The table of actual magic unfoldings}
70 %************************************************************************
75 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
78 = [(SLIT("augment"), MUF augment_fun),
79 (SLIT("build"), MUF build_fun),
80 (SLIT("foldl"), MUF foldl_fun),
81 (SLIT("foldr"), MUF foldr_fun),
82 (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun),
83 (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
86 %************************************************************************
88 \subsubsection{Unfolding function for @append@}
90 %************************************************************************
93 -- First build, the way we express our lists.
97 -> SmplM (Maybe CoreExpr)
98 build_fun env [TypeArg ty,ValArg (VarArg e)]
99 | switchIsSet env SimplDoInlineFoldrBuild =
102 ourCons = CoTyApp (Var consDataCon) ty
103 ourNil = CoTyApp (Var nilDataCon) ty
105 newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
106 returnSmpl(Just (Let (NonRec c ourCons)
107 (Let (NonRec n ourNil)
108 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
109 -- ToDo: add `build' without an argument instance.
110 -- This is strange, because of g's type.
112 ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
117 augment_fun :: SimplEnv
119 -> SmplM (Maybe CoreExpr)
121 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
122 | switchIsSet env SimplDoInlineFoldrBuild =
125 ourCons = CoTyApp (Var consDataCon) ty
127 newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
128 returnSmpl (Just (Let (NonRec c ourCons)
129 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
130 -- ToDo: add `build' without an argument instance.
131 -- This is strange, because of g's type.
133 ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
137 Now foldr, the way we consume lists.
140 foldr_fun :: SimplEnv
142 -> SmplM (Maybe CoreExpr)
144 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
145 | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
146 = -- foldr (:) [] ==> id
147 -- this transformation is *always* benificial
148 -- cf. foldr (:) [] (build g) == g (:) []
149 -- with foldr (:) [] (build g) == build g
150 -- after unfolding build, they are the same thing.
151 tick Foldr_Cons_Nil `thenSmpl_`
152 newId (mkListTy ty1) `thenSmpl` \ x ->
153 returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
155 do_fb_red = switchIsSet env SimplDoFoldrBuild
157 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
158 | do_fb_red && isNilForm env arg_list
159 = -- foldr f z [] = z
160 -- again another short cut, helps with unroling of constant lists
161 tick Foldr_Nil `thenSmpl_`
162 returnSmpl (Just (argToExpr arg_z))
164 | do_fb_red && arg_list_isBuildForm
165 = -- foldr k z (build g) ==> g k z
166 -- this next line *is* the foldr/build rule proper.
167 tick FoldrBuild `thenSmpl_`
168 returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
170 | do_fb_red && arg_list_isAugmentForm
171 = -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
172 -- this next line *is* the foldr/augment rule proper.
173 tick FoldrAugment `thenSmpl_`
174 newId ty2 `thenSmpl` \ v ->
176 (Let (NonRec v (mkGenApp (Var foldrId)
177 [TypeArg ty1,TypeArg ty2,
181 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
183 | do_fb_red && arg_list_isListForm
184 = -- foldr k z (a:b:c:rest) =
185 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
186 -- NB: 'k' is used just one by foldr, but 'f' is used many
187 -- times inside the list structure. This means that
188 -- 'f' needs to be inside a lambda, to make sure the simplifier
192 -- f a (f b (f c (foldr f z rest)))
194 -- let ele_1 = foldr f z rest
199 tick Foldr_List `thenSmpl_`
201 mkFunTys [ty1, ty2] ty2 :
202 nOfThem (length the_list) ty2
203 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
207 (mkGenApp (Var foldrId)
208 [TypeArg ty1,TypeArg ty2,
209 ValArg (VarArg f_id),
212 rest_binds = zipWith3Equal "Foldr:rest_binds"
213 (\ e v e' -> NonRec e (mkRhs v e'))
215 (reverse (tail the_list))
216 (init (ele_id1:ele_ids))
217 mkRhs v e = App (App (Var f_id) v) (VarArg e)
220 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
221 (fst_bind:rest_binds)
223 returnSmpl (Just (mkGenApp (Lam f_id core_list)
224 (ValArg arg_k:rest_args)))
229 | do_fb_red && arg_list_isStringForm -- ok, its a string!
230 -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
231 = tick Str_FoldrStr `thenSmpl_`
232 returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
234 ValArg (LitArg (MachStr str_val)):
239 do_fb_red = switchIsSet env SimplDoFoldrBuild
241 arg_list_isStringForm = maybeToBool stringForm
242 stringForm = getStringForm env arg_list
243 (Just str_val) = stringForm
245 arg_list_isBuildForm = maybeToBool buildForm
246 buildForm = getBuildForm env arg_list
249 arg_list_isAugmentForm = maybeToBool augmentForm
250 augmentForm = getAugmentForm env arg_list
251 (Just (g',h)) = augmentForm
253 arg_list_isListForm = maybeToBool listForm
254 listForm = getListForm env arg_list
255 (Just (the_list,the_tl)) = listForm
257 arg_list_isAppendForm = maybeToBool appendForm
258 appendForm = getAppendForm env arg_list
259 (Just (xs,ys)) = appendForm
262 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
263 | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
264 = -- foldr (:) z xs = xs ++ z
265 tick Foldr_Cons `thenSmpl_`
266 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
267 returnSmpl (Just (mkGenApp
268 (Lam z (Lam x (mkGenApp
272 ValArg (VarArg z)])))
274 | doing_inlining && (isInterestingArg env arg_k
275 || isConsFun env arg_k)
281 -- (a:b) -> f a (h b)
285 -- tick FoldrInline `thenSmpl_`
288 mkListTy ty1, -- b :: [t1]
290 mkListTy ty1, -- x :: t1
291 mkFunTys [mkListTy ty1] ty2,
293 mkFunTys [ty1, ty2] ty2,
297 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
299 h_rhs = (Lam x (Case (Var x)
301 [(nilDataCon,[],argToExpr (VarArg z)),
302 (consDataCon,[a,b],body)]
304 body = Let (NonRec v (App (Var h) (VarArg b)))
305 (App (App (argToExpr (VarArg f))
311 (Lam f (Lam z (Lam xs
312 (Let (Rec [(h,h_rhs)])
313 (App (Var h) (VarArg xs))))))
314 (ValArg arg_k:rest_args)))
316 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
317 dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
318 foldr_fun _ _ = returnSmpl Nothing
320 isConsFun :: SimplEnv -> CoreArg -> Bool
321 isConsFun env (VarArg v)
322 = case lookupUnfolding env v of
323 GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
324 | con == consDataCon && x==x' && y==y'
325 -> ASSERT ( length tys == 1 ) True
327 isConsFun env _ = False
329 isNilForm :: SimplEnv -> CoreArg -> Bool
330 isNilForm env (VarArg v)
331 = case lookupUnfolding env v of
332 GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
333 GenForm _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
335 isNilForm env _ = False
337 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
338 getBuildForm env (VarArg v)
339 = case lookupUnfolding env v of
340 GenForm False _ _ _ -> Nothing
341 -- not allowed to inline :-(
342 GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
343 | bld == buildId -> Just g
344 GenForm _ (App (App (CoTyApp (Var bld) _)
346 | bld == augmentId && isNilForm env h -> Just g
348 getBuildForm env _ = Nothing
352 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
353 getAugmentForm env (VarArg v)
354 = case lookupUnfolding env v of
355 GenForm False _ _ _ -> Nothing
356 -- not allowed to inline :-(
357 GenForm _ (App (App (CoTyApp (Var bld) _)
359 | bld == augmentId -> Just (g,h)
361 getAugmentForm env _ = Nothing
363 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
364 getStringForm env (LitArg (NoRepStr str)) = Just str
365 getStringForm env _ = Nothing
368 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
369 getAppendForm env (VarArg v) =
370 case lookupUnfolding env v of
371 GenForm False _ _ _ -> Nothing -- not allowed to inline :-(
372 GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
373 | fld == foldrId && isConsFun env con -> Just (xs,ys)
375 getAppendForm env _ = Nothing
379 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
380 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
386 -> Maybe ([CoreArg],CoreArg)
387 getListForm env (VarArg v)
388 = case lookupUnfolding env v of
389 GenForm _ (Con id [ty_arg,head,tail]) _
390 | id == consDataCon ->
391 case getListForm env tail of
392 Nothing -> Just ([head],tail)
393 Just (lst,new_tail) -> Just (head:lst,new_tail)
395 getListForm env _ = Nothing
397 isInterestingArg :: SimplEnv -> CoreArg -> Bool
398 isInterestingArg env (VarArg v)
399 = case lookupUnfolding env v of
400 GenForm False _ _ UnfoldNever -> False
401 GenForm _ exp guide -> True
403 isInterestingArg env _ = False
405 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
406 | do_fb_red && isNilForm env arg_list
407 = -- foldl f z [] = z
408 -- again another short cut, helps with unroling of constant lists
409 tick Foldl_Nil `thenSmpl_`
410 returnSmpl (Just (argToExpr arg_z))
412 | do_fb_red && arg_list_isBuildForm
413 = -- foldl t1 t2 k z (build t3 g) ==>
414 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
415 -- n {- INLINE -} = \ a -> a
417 -- this next line *is* the foldr/build rule proper.
418 tick FoldlBuild `thenSmpl_`
419 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
422 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
423 {- pre_n -} mkFunTys [ty1] ty1,
425 {- g' -} mkFunTys [ty1] ty1,
429 ] `thenSmpl` \ [pre_c,
438 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
439 c_rhs = Lam b (Lam g' (Lam a
440 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
441 (App (Var g') (VarArg t)))))
442 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
443 n_rhs = Lam a' (Var a')
445 returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
447 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
448 :ValArg arg_z:rest_args)))))
450 | do_fb_red && arg_list_isAugmentForm
451 = -- foldl t1 t2 k z (augment t3 g h) ==>
452 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
453 -- n {- INLINE -} = \ a -> a
454 -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
456 -- this next line *is* the foldr/build rule proper.
457 tick FoldlAugment `thenSmpl_`
458 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
461 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
462 {- pre_n -} mkFunTys [ty1] ty1,
463 {- pre_r -} mkFunTys [ty1] ty1,
465 {- g_ -} mkFunTys [ty1] ty1,
469 ] `thenSmpl` \ [pre_c,
479 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
480 c_rhs = Lam b (Lam g_ (Lam a
481 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
482 (App (Var g_) (VarArg t)))))
483 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
484 n_rhs = Lam a' (Var a')
485 r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
486 r_rhs = mkGenApp (Var foldrId)
487 [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
492 returnSmpl (Just (Let (NonRec c c_rhs)
493 (Let (NonRec n n_rhs)
494 (Let (NonRec r r_rhs)
496 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
497 :ValArg arg_z:rest_args))))))
499 | do_fb_red && arg_list_isListForm
500 = -- foldl k z (a:b:c:rest) =
501 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
502 -- NB: 'k' is used just one by foldr, but 'f' is used many
503 -- times inside the list structure. This means that
504 -- 'f' needs to be inside a lambda, to make sure the simplifier
508 -- foldl f (f (f (f z a) b) c) rest
509 -- f a (f b (f c (foldr f z rest)))
514 -- in foldl f ele_3 rest
516 tick Foldl_List `thenSmpl_`
518 mkFunTys [ty1, ty2] ty1 :
519 nOfThem (length the_list) ty1
520 ) `thenSmpl` \ (f_id:ele_ids) ->
522 rest_binds = zipWith3Equal "foldl:rest_binds"
523 (\ e v e' -> NonRec e (mkRhs v e'))
525 the_list -- :: [CoreArg]
526 (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
527 mkRhs v e = App (App (Var f_id) e) v
529 last_bind = mkGenApp (Var foldlId)
530 [TypeArg ty1,TypeArg ty2,
531 ValArg (VarArg f_id),
532 ValArg (VarArg (last ele_ids)),
539 returnSmpl (Just (mkGenApp (Lam f_id core_list)
540 (ValArg arg_k:rest_args)))
543 do_fb_red = switchIsSet env SimplDoFoldrBuild
545 arg_list_isAugmentForm = maybeToBool augmentForm
546 augmentForm = getAugmentForm env arg_list
547 (Just (g',h)) = augmentForm
549 arg_list_isBuildForm = maybeToBool buildForm
550 buildForm = getBuildForm env arg_list
553 arg_list_isListForm = maybeToBool listForm
554 listForm = getListForm env arg_list
555 (Just (the_list,the_tl)) = listForm
558 arg_list_isAppendForm = maybeToBool appendForm
559 appendForm = getAppendForm env arg_list
560 (Just (xs,ys)) = appendForm
563 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
564 | doing_inlining && (isInterestingArg env arg_k
565 || isConsFun env arg_k)
571 -- (a:b) -> h b (f r a)
575 -- tick FoldrInline `thenSmpl_`
578 mkListTy ty2, -- b :: [t1]
580 mkListTy ty2, -- x :: t1
581 mkFunTys [mkListTy ty2, ty1] ty1,
582 -- h :: [t2] -> t1 -> t1
583 mkFunTys [ty1, ty2] ty1,
588 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
590 h_rhs = (Lam x (Lam r (Case (Var x))
592 [(nilDataCon,[],argToExpr (VarArg r)),
593 (consDataCon,[a,b],body)]
595 body = Let (NonRec v (App (App (Var f) (VarArg r))
597 (App (App (argToExpr (VarArg h))
603 (Lam f (Lam z (Lam xs
604 (Let (Rec [(h,h_rhs)])
605 (App (App (Var h) (VarArg xs))
607 (ValArg arg_k:rest_args)))
609 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
611 foldl_fun env _ = returnSmpl Nothing
617 -- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
619 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
620 | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
621 = tick Str_UnpackCons `thenSmpl_`
622 returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
625 unpack_foldr_fun env _ = returnSmpl Nothing
627 unpack_append_fun env
628 [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
629 | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
630 = tick Str_UnpackNil `thenSmpl_`
631 returnSmpl (Just (Lit (NoRepStr str_val)))
632 unpack_append_fun env _ = returnSmpl Nothing