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 -> Maybe (SmplM 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 -> Maybe (SmplM 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 -> Maybe (SmplM CoreExpr)
98 build_fun env [TypeArg ty,ValArg (VarArg e)]
99 | switchIsSet env SimplDoInlineFoldrBuild
103 ourCons = CoTyApp (Var consDataCon) ty
104 ourNil = CoTyApp (Var nilDataCon) ty
106 result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
107 returnSmpl(Let (NonRec c ourCons)
108 (Let (NonRec n ourNil)
109 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
111 -- ToDo: add `build' without an argument instance.
112 -- This is strange, because of g's type.
113 build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
118 augment_fun :: SimplEnv
120 -> Maybe (SmplM CoreExpr)
122 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
123 | switchIsSet env SimplDoInlineFoldrBuild
127 ourCons = CoTyApp (Var consDataCon) ty
128 result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
129 returnSmpl (Let (NonRec c ourCons)
130 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
131 -- ToDo: add `build' without an argument instance.
132 -- This is strange, because of g's type.
134 augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
138 Now foldr, the way we consume lists.
141 foldr_fun :: SimplEnv
143 -> Maybe (SmplM CoreExpr)
145 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
146 | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
147 -- foldr (:) [] ==> id
148 -- this transformation is *always* benificial
149 -- cf. foldr (:) [] (build g) == g (:) []
150 -- with foldr (:) [] (build g) == build g
151 -- after unfolding build, they are the same thing.
152 = Just (tick Foldr_Cons_Nil `thenSmpl_`
153 newId (mkListTy ty1) `thenSmpl` \ x ->
154 returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
157 do_fb_red = switchIsSet env SimplDoFoldrBuild
159 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
160 | do_fb_red && isNilForm env arg_list
162 -- again another short cut, helps with unroling of constant lists
163 = Just (tick Foldr_Nil `thenSmpl_`
164 returnSmpl (argToExpr arg_z)
167 | do_fb_red && arg_list_isBuildForm
168 -- foldr k z (build g) ==> g k z
169 -- this next line *is* the foldr/build rule proper.
170 = Just (tick FoldrBuild `thenSmpl_`
171 returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
174 | do_fb_red && arg_list_isAugmentForm
175 -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
176 -- this next line *is* the foldr/augment rule proper.
177 = Just (tick FoldrAugment `thenSmpl_`
178 newId ty2 `thenSmpl` \ v ->
180 Let (NonRec v (mkGenApp (Var foldrId)
181 [TypeArg ty1,TypeArg ty2,
185 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
188 | do_fb_red && arg_list_isListForm
189 -- foldr k z (a:b:c:rest) =
190 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
191 -- NB: 'k' is used just one by foldr, but 'f' is used many
192 -- times inside the list structure. This means that
193 -- 'f' needs to be inside a lambda, to make sure the simplifier
197 -- f a (f b (f c (foldr f z rest)))
199 -- let ele_1 = foldr f z rest
204 = Just (tick Foldr_List `thenSmpl_`
206 mkFunTys [ty1, ty2] ty2 :
207 nOfThem (length the_list) ty2
208 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
212 (mkGenApp (Var foldrId)
213 [TypeArg ty1,TypeArg ty2,
214 ValArg (VarArg f_id),
217 rest_binds = zipWith3Equal "Foldr:rest_binds"
218 (\ e v e' -> NonRec e (mkRhs v e'))
220 (reverse (tail the_list))
221 (init (ele_id1:ele_ids))
222 mkRhs v e = App (App (Var f_id) v) (VarArg e)
225 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
226 (fst_bind:rest_binds)
228 returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
234 | do_fb_red && arg_list_isStringForm -- ok, its a string!
235 -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
236 = Just (tick Str_FoldrStr `thenSmpl_`
237 returnSmpl (mkGenApp (Var unpackCStringFoldrId)
239 ValArg (LitArg (MachStr str_val)):
245 do_fb_red = switchIsSet env SimplDoFoldrBuild
247 arg_list_isStringForm = maybeToBool stringForm
248 stringForm = getStringForm env arg_list
249 (Just str_val) = stringForm
251 arg_list_isBuildForm = maybeToBool buildForm
252 buildForm = getBuildForm env arg_list
255 arg_list_isAugmentForm = maybeToBool augmentForm
256 augmentForm = getAugmentForm env arg_list
257 (Just (g',h)) = augmentForm
259 arg_list_isListForm = maybeToBool listForm
260 listForm = getListForm env arg_list
261 (Just (the_list,the_tl)) = listForm
263 arg_list_isAppendForm = maybeToBool appendForm
264 appendForm = getAppendForm env arg_list
265 (Just (xs,ys)) = appendForm
268 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
269 | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
270 -- foldr (:) z xs = xs ++ z
271 = Just (tick Foldr_Cons `thenSmpl_`
272 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
274 (Lam z (Lam x (mkGenApp
282 | doing_inlining && (isInterestingArg env arg_k
283 || isConsFun env arg_k)
289 -- (a:b) -> f a (h b)
293 -- tick FoldrInline `thenSmpl_`
296 mkListTy ty1, -- b :: [t1]
298 mkListTy ty1, -- x :: t1
299 mkFunTys [mkListTy ty1] ty2,
301 mkFunTys [ty1, ty2] ty2,
305 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
307 h_rhs = (Lam x (Case (Var x)
309 [(nilDataCon,[],argToExpr (VarArg z)),
310 (consDataCon,[a,b],body)]
312 body = Let (NonRec v (App (Var h) (VarArg b)))
313 (App (App (argToExpr (VarArg f))
319 (Lam f (Lam z (Lam xs
320 (Let (Rec [(h,h_rhs)])
321 (App (Var h) (VarArg xs))))))
322 (ValArg arg_k:rest_args))
325 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
326 dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
328 foldr_fun _ _ = Nothing
330 isConsFun :: SimplEnv -> CoreArg -> Bool
331 isConsFun env (VarArg v)
332 = case lookupUnfolding env v of
333 SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
334 | con == consDataCon && x==x' && y==y'
335 -> ASSERT ( length tys == 1 ) True
337 isConsFun env _ = False
339 isNilForm :: SimplEnv -> CoreArg -> Bool
340 isNilForm env (VarArg v)
341 = case lookupUnfolding env v of
342 SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
343 SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
345 isNilForm env _ = False
347 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
348 getBuildForm env (VarArg v)
349 = case lookupUnfolding env v of
350 SimpleUnfolding False _ _ _ -> Nothing
351 -- not allowed to inline :-(
352 SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
353 | bld == buildId -> Just g
354 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
356 | bld == augmentId && isNilForm env h -> Just g
358 getBuildForm env _ = Nothing
362 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
363 getAugmentForm env (VarArg v)
364 = case lookupUnfolding env v of
365 SimpleUnfolding False _ _ _ -> Nothing
366 -- not allowed to inline :-(
367 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
369 | bld == augmentId -> Just (g,h)
371 getAugmentForm env _ = Nothing
373 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
374 getStringForm env (LitArg (NoRepStr str)) = Just str
375 getStringForm env _ = Nothing
378 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
379 getAppendForm env (VarArg v) =
380 case lookupUnfolding env v of
381 SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
382 SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
383 | fld == foldrId && isConsFun env con -> Just (xs,ys)
385 getAppendForm env _ = Nothing
389 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
390 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
396 -> Maybe ([CoreArg],CoreArg)
397 getListForm env (VarArg v)
398 = case lookupUnfolding env v of
399 SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
400 | id == consDataCon ->
401 case getListForm env tail of
402 Nothing -> Just ([head],tail)
403 Just (lst,new_tail) -> Just (head:lst,new_tail)
405 getListForm env _ = Nothing
407 isInterestingArg :: SimplEnv -> CoreArg -> Bool
408 isInterestingArg env (VarArg v)
409 = case lookupUnfolding env v of
410 SimpleUnfolding False _ _ UnfoldNever -> False
411 SimpleUnfolding _ exp guide -> True
413 isInterestingArg env _ = False
415 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
416 | do_fb_red && isNilForm env arg_list
418 -- again another short cut, helps with unroling of constant lists
419 = Just (tick Foldl_Nil `thenSmpl_`
420 returnSmpl (argToExpr arg_z)
423 | do_fb_red && arg_list_isBuildForm
424 -- foldl t1 t2 k z (build t3 g) ==>
425 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
426 -- n {- INLINE -} = \ a -> a
428 -- this next line *is* the foldr/build rule proper.
429 = Just(tick FoldlBuild `thenSmpl_`
430 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
433 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
434 {- pre_n -} mkFunTys [ty1] ty1,
436 {- g' -} mkFunTys [ty1] ty1,
440 ] `thenSmpl` \ [pre_c,
449 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
450 c_rhs = Lam b (Lam g' (Lam a
451 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
452 (App (Var g') (VarArg t)))))
453 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
454 n_rhs = Lam a' (Var a')
456 returnSmpl (Let (NonRec c c_rhs) $
457 Let (NonRec n n_rhs) $
459 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
460 :ValArg arg_z:rest_args))
463 | do_fb_red && arg_list_isAugmentForm
464 -- foldl t1 t2 k z (augment t3 g h) ==>
465 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
466 -- n {- INLINE -} = \ a -> a
467 -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
469 -- this next line *is* the foldr/build rule proper.
470 = Just (tick FoldlAugment `thenSmpl_`
471 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
474 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
475 {- pre_n -} mkFunTys [ty1] ty1,
476 {- pre_r -} mkFunTys [ty1] ty1,
478 {- g_ -} mkFunTys [ty1] ty1,
482 ] `thenSmpl` \ [pre_c,
492 c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
493 c_rhs = Lam b (Lam g_ (Lam a
494 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
495 (App (Var g_) (VarArg t)))))
496 n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
497 n_rhs = Lam a' (Var a')
498 r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
499 r_rhs = mkGenApp (Var foldrId)
500 [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
505 returnSmpl (Let (NonRec c c_rhs) $
506 Let (NonRec n n_rhs) $
507 Let (NonRec r r_rhs) $
509 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
510 :ValArg arg_z:rest_args))
513 | do_fb_red && arg_list_isListForm
514 -- foldl k z (a:b:c:rest) =
515 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
516 -- NB: 'k' is used just one by foldr, but 'f' is used many
517 -- times inside the list structure. This means that
518 -- 'f' needs to be inside a lambda, to make sure the simplifier
522 -- foldl f (f (f (f z a) b) c) rest
523 -- f a (f b (f c (foldr f z rest)))
528 -- in foldl f ele_3 rest
530 = Just (tick Foldl_List `thenSmpl_`
532 mkFunTys [ty1, ty2] ty1 :
533 nOfThem (length the_list) ty1
534 ) `thenSmpl` \ (f_id:ele_ids) ->
536 rest_binds = zipWith3Equal "foldl:rest_binds"
537 (\ e v e' -> NonRec e (mkRhs v e'))
539 the_list -- :: [CoreArg]
540 (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
541 mkRhs v e = App (App (Var f_id) e) v
543 last_bind = mkGenApp (Var foldlId)
544 [TypeArg ty1,TypeArg ty2,
545 ValArg (VarArg f_id),
546 ValArg (VarArg (last ele_ids)),
553 returnSmpl (mkGenApp (Lam f_id core_list)
554 (ValArg arg_k:rest_args))
558 do_fb_red = switchIsSet env SimplDoFoldrBuild
560 arg_list_isAugmentForm = maybeToBool augmentForm
561 augmentForm = getAugmentForm env arg_list
562 (Just (g',h)) = augmentForm
564 arg_list_isBuildForm = maybeToBool buildForm
565 buildForm = getBuildForm env arg_list
568 arg_list_isListForm = maybeToBool listForm
569 listForm = getListForm env arg_list
570 (Just (the_list,the_tl)) = listForm
573 arg_list_isAppendForm = maybeToBool appendForm
574 appendForm = getAppendForm env arg_list
575 (Just (xs,ys)) = appendForm
578 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
579 | doing_inlining && (isInterestingArg env arg_k
580 || isConsFun env arg_k)
586 -- (a:b) -> h b (f r a)
591 -- tick FoldrInline `thenSmpl_`
594 mkListTy ty2, -- b :: [t1]
596 mkListTy ty2, -- x :: t1
597 mkFunTys [mkListTy ty2, ty1] ty1,
598 -- h :: [t2] -> t1 -> t1
599 mkFunTys [ty1, ty2] ty1,
604 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
606 h_rhs = (Lam x (Lam r (Case (Var x))
608 [(nilDataCon,[],argToExpr (VarArg r)),
609 (consDataCon,[a,b],body)]
611 body = Let (NonRec v (App (App (Var f) (VarArg r))
613 (App (App (argToExpr (VarArg h))
619 (Lam f (Lam z (Lam xs
620 (Let (Rec [(h,h_rhs)])
621 (App (App (Var h) (VarArg xs))
623 (ValArg arg_k:rest_args))
626 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
628 foldl_fun env _ = Nothing
634 -- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
636 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
637 | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
638 = Just (tick Str_UnpackCons `thenSmpl_`
639 returnSmpl (mkGenApp (Var unpackCStringAppendId)
643 unpack_foldr_fun env _ = Nothing
645 unpack_append_fun env
646 [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
647 | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
648 = Just (tick Str_UnpackNil `thenSmpl_`
649 returnSmpl (Lit (NoRepStr str_val))
651 unpack_append_fun env _ = Nothing