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
19 import Id ( addInlinePragma )
21 import SimplEnv ( SimplEnv )
22 import SimplMonad ( SYN_IE(SmplM), SimplCount )
23 import Type ( mkFunTys )
24 import TysWiredIn ( mkListTy )
25 import Unique ( Unique{-instances-} )
26 import Util ( assoc, zipWith3Equal, nOfThem, panic )
29 %************************************************************************
31 \subsection{Types, etc., for magic-unfolding functions}
33 %************************************************************************
36 data MagicUnfoldingFun
37 = MUF ( SimplEnv -- state of play in simplifier...
38 -- (note: we can get simplifier switches
40 -> [CoreArg] -- arguments
41 -> Maybe (SmplM CoreExpr))
42 -- Just result, or Nothing
45 Give us a value's @Unique@, we'll give you back the corresponding MUF.
47 mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
49 mkMagicUnfoldingFun tag
50 = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
52 magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
55 Give us an MUF and stuff to apply it to, and we'll give you back the
58 applyMagicUnfoldingFun
62 -> Maybe (SmplM CoreExpr)
64 applyMagicUnfoldingFun (MUF fun) env args = fun env args
67 %************************************************************************
69 \subsection{The table of actual magic unfoldings}
71 %************************************************************************
76 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
79 = [(SLIT("augment"), MUF augment_fun),
80 (SLIT("build"), MUF build_fun),
81 (SLIT("foldl"), MUF foldl_fun),
82 (SLIT("foldr"), MUF foldr_fun),
83 (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun),
84 (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
87 %************************************************************************
89 \subsubsection{Unfolding function for @append@}
91 %************************************************************************
94 -- First build, the way we express our lists.
98 -> Maybe (SmplM CoreExpr)
99 build_fun env [TypeArg ty,ValArg (VarArg e)]
100 | switchIsSet env SimplDoInlineFoldrBuild
104 ourCons = CoTyApp (Var consDataCon) ty
105 ourNil = CoTyApp (Var nilDataCon) ty
107 result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
108 returnSmpl(Let (NonRec c ourCons)
109 (Let (NonRec n ourNil)
110 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
112 -- ToDo: add `build' without an argument instance.
113 -- This is strange, because of g's type.
114 build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
119 augment_fun :: SimplEnv
121 -> Maybe (SmplM CoreExpr)
123 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
124 | switchIsSet env SimplDoInlineFoldrBuild
128 ourCons = CoTyApp (Var consDataCon) ty
129 result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
130 returnSmpl (Let (NonRec c ourCons)
131 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
132 -- ToDo: add `build' without an argument instance.
133 -- This is strange, because of g's type.
135 augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
139 Now foldr, the way we consume lists.
142 foldr_fun :: SimplEnv
144 -> Maybe (SmplM CoreExpr)
146 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
147 | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
148 -- foldr (:) [] ==> id
149 -- this transformation is *always* benificial
150 -- cf. foldr (:) [] (build g) == g (:) []
151 -- with foldr (:) [] (build g) == build g
152 -- after unfolding build, they are the same thing.
153 = Just (tick Foldr_Cons_Nil `thenSmpl_`
154 newId (mkListTy ty1) `thenSmpl` \ x ->
155 returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
158 do_fb_red = switchIsSet env SimplDoFoldrBuild
160 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
161 | do_fb_red && isNilForm env arg_list
163 -- again another short cut, helps with unroling of constant lists
164 = Just (tick Foldr_Nil `thenSmpl_`
165 returnSmpl (argToExpr arg_z)
168 | do_fb_red && arg_list_isBuildForm
169 -- foldr k z (build g) ==> g k z
170 -- this next line *is* the foldr/build rule proper.
171 = Just (tick FoldrBuild `thenSmpl_`
172 returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
175 | do_fb_red && arg_list_isAugmentForm
176 -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
177 -- this next line *is* the foldr/augment rule proper.
178 = Just (tick FoldrAugment `thenSmpl_`
179 newId ty2 `thenSmpl` \ v ->
181 Let (NonRec v (mkGenApp (Var foldrId)
182 [TypeArg ty1,TypeArg ty2,
186 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
189 | do_fb_red && arg_list_isListForm
190 -- foldr k z (a:b:c:rest) =
191 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
192 -- NB: 'k' is used just one by foldr, but 'f' is used many
193 -- times inside the list structure. This means that
194 -- 'f' needs to be inside a lambda, to make sure the simplifier
198 -- f a (f b (f c (foldr f z rest)))
200 -- let ele_1 = foldr f z rest
205 = Just (tick Foldr_List `thenSmpl_`
207 mkFunTys [ty1, ty2] ty2 :
208 nOfThem (length the_list) ty2
209 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
213 (mkGenApp (Var foldrId)
214 [TypeArg ty1,TypeArg ty2,
215 ValArg (VarArg f_id),
218 rest_binds = zipWith3Equal "Foldr:rest_binds"
219 (\ e v e' -> NonRec e (mkRhs v e'))
221 (reverse (tail the_list))
222 (init (ele_id1:ele_ids))
223 mkRhs v e = App (App (Var f_id) v) (VarArg e)
226 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
227 (fst_bind:rest_binds)
229 returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
235 | do_fb_red && arg_list_isStringForm -- ok, its a string!
236 -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
237 = Just (tick Str_FoldrStr `thenSmpl_`
238 returnSmpl (mkGenApp (Var unpackCStringFoldrId)
240 ValArg (LitArg (MachStr str_val)):
246 do_fb_red = switchIsSet env SimplDoFoldrBuild
248 arg_list_isStringForm = maybeToBool stringForm
249 stringForm = getStringForm env arg_list
250 (Just str_val) = stringForm
252 arg_list_isBuildForm = maybeToBool buildForm
253 buildForm = getBuildForm env arg_list
256 arg_list_isAugmentForm = maybeToBool augmentForm
257 augmentForm = getAugmentForm env arg_list
258 (Just (g',h)) = augmentForm
260 arg_list_isListForm = maybeToBool listForm
261 listForm = getListForm env arg_list
262 (Just (the_list,the_tl)) = listForm
264 arg_list_isAppendForm = maybeToBool appendForm
265 appendForm = getAppendForm env arg_list
266 (Just (xs,ys)) = appendForm
269 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
270 | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
271 -- foldr (:) z xs = xs ++ z
272 = Just (tick Foldr_Cons `thenSmpl_`
273 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
275 (Lam z (Lam x (mkGenApp
283 | doing_inlining && (isInterestingArg env arg_k
284 || isConsFun env arg_k)
290 -- (a:b) -> f a (h b)
294 -- tick FoldrInline `thenSmpl_`
297 mkListTy ty1, -- b :: [t1]
299 mkListTy ty1, -- x :: t1
300 mkFunTys [mkListTy ty1] ty2,
302 mkFunTys [ty1, ty2] ty2,
306 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
308 h_rhs = (Lam x (Case (Var x)
310 [(nilDataCon,[],argToExpr (VarArg z)),
311 (consDataCon,[a,b],body)]
313 body = Let (NonRec v (App (Var h) (VarArg b)))
314 (App (App (argToExpr (VarArg f))
320 (Lam f (Lam z (Lam xs
321 (Let (Rec [(h,h_rhs)])
322 (App (Var h) (VarArg xs))))))
323 (ValArg arg_k:rest_args))
326 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
327 dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
329 foldr_fun _ _ = Nothing
331 isConsFun :: SimplEnv -> CoreArg -> Bool
332 isConsFun env (VarArg v)
333 = case lookupUnfolding env v of
334 SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
335 | con == consDataCon && x==x' && y==y'
336 -> ASSERT ( length tys == 1 ) True
338 isConsFun env _ = False
340 isNilForm :: SimplEnv -> CoreArg -> Bool
341 isNilForm env (VarArg v)
342 = case lookupUnfolding env v of
343 SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
344 SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
346 isNilForm env _ = False
348 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
349 getBuildForm env (VarArg v)
350 = case lookupUnfolding env v of
351 SimpleUnfolding False _ _ _ -> Nothing
352 -- not allowed to inline :-(
353 SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
354 | bld == buildId -> Just g
355 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
357 | bld == augmentId && isNilForm env h -> Just g
359 getBuildForm env _ = Nothing
363 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
364 getAugmentForm env (VarArg v)
365 = case lookupUnfolding env v of
366 SimpleUnfolding False _ _ _ -> Nothing
367 -- not allowed to inline :-(
368 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
370 | bld == augmentId -> Just (g,h)
372 getAugmentForm env _ = Nothing
374 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
375 getStringForm env (LitArg (NoRepStr str)) = Just str
376 getStringForm env _ = Nothing
379 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
380 getAppendForm env (VarArg v) =
381 case lookupUnfolding env v of
382 SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
383 SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
384 | fld == foldrId && isConsFun env con -> Just (xs,ys)
386 getAppendForm env _ = Nothing
390 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
391 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
397 -> Maybe ([CoreArg],CoreArg)
398 getListForm env (VarArg v)
399 = case lookupUnfolding env v of
400 SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
401 | id == consDataCon ->
402 case getListForm env tail of
403 Nothing -> Just ([head],tail)
404 Just (lst,new_tail) -> Just (head:lst,new_tail)
406 getListForm env _ = Nothing
408 isInterestingArg :: SimplEnv -> CoreArg -> Bool
409 isInterestingArg env (VarArg v)
410 = case lookupUnfolding env v of
411 SimpleUnfolding False _ _ UnfoldNever -> False
412 SimpleUnfolding _ exp guide -> True
414 isInterestingArg env _ = False
416 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
417 | do_fb_red && isNilForm env arg_list
419 -- again another short cut, helps with unroling of constant lists
420 = Just (tick Foldl_Nil `thenSmpl_`
421 returnSmpl (argToExpr arg_z)
424 | do_fb_red && arg_list_isBuildForm
425 -- foldl t1 t2 k z (build t3 g) ==>
426 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
427 -- n {- INLINE -} = \ a -> a
429 -- this next line *is* the foldr/build rule proper.
430 = Just(tick FoldlBuild `thenSmpl_`
431 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
434 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
435 {- pre_n -} mkFunTys [ty1] ty1,
437 {- g' -} mkFunTys [ty1] ty1,
441 ] `thenSmpl` \ [pre_c,
450 c = addInlinePragma pre_c
451 c_rhs = Lam b (Lam g' (Lam a
452 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
453 (App (Var g') (VarArg t)))))
454 n = addInlinePragma pre_n
455 n_rhs = Lam a' (Var a')
457 returnSmpl (Let (NonRec c c_rhs) $
458 Let (NonRec n n_rhs) $
460 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
461 :ValArg arg_z:rest_args))
464 | do_fb_red && arg_list_isAugmentForm
465 -- foldl t1 t2 k z (augment t3 g h) ==>
466 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
467 -- n {- INLINE -} = \ a -> a
468 -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
470 -- this next line *is* the foldr/build rule proper.
471 = Just (tick FoldlAugment `thenSmpl_`
472 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
475 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
476 {- pre_n -} mkFunTys [ty1] ty1,
477 {- pre_r -} mkFunTys [ty1] ty1,
479 {- g_ -} mkFunTys [ty1] ty1,
483 ] `thenSmpl` \ [pre_c,
493 c = addInlinePragma pre_c
494 c_rhs = Lam b (Lam g_ (Lam a
495 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
496 (App (Var g_) (VarArg t)))))
497 n = addInlinePragma pre_n
498 n_rhs = Lam a' (Var a')
499 r = addInlinePragma pre_r
500 r_rhs = mkGenApp (Var foldrId)
501 [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
506 returnSmpl (Let (NonRec c c_rhs) $
507 Let (NonRec n n_rhs) $
508 Let (NonRec r r_rhs) $
510 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
511 :ValArg arg_z:rest_args))
514 | do_fb_red && arg_list_isListForm
515 -- foldl k z (a:b:c:rest) =
516 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
517 -- NB: 'k' is used just one by foldr, but 'f' is used many
518 -- times inside the list structure. This means that
519 -- 'f' needs to be inside a lambda, to make sure the simplifier
523 -- foldl f (f (f (f z a) b) c) rest
524 -- f a (f b (f c (foldr f z rest)))
529 -- in foldl f ele_3 rest
531 = Just (tick Foldl_List `thenSmpl_`
533 mkFunTys [ty1, ty2] ty1 :
534 nOfThem (length the_list) ty1
535 ) `thenSmpl` \ (f_id:ele_ids) ->
537 rest_binds = zipWith3Equal "foldl:rest_binds"
538 (\ e v e' -> NonRec e (mkRhs v e'))
540 the_list -- :: [CoreArg]
541 (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
542 mkRhs v e = App (App (Var f_id) e) v
544 last_bind = mkGenApp (Var foldlId)
545 [TypeArg ty1,TypeArg ty2,
546 ValArg (VarArg f_id),
547 ValArg (VarArg (last ele_ids)),
554 returnSmpl (mkGenApp (Lam f_id core_list)
555 (ValArg arg_k:rest_args))
559 do_fb_red = switchIsSet env SimplDoFoldrBuild
561 arg_list_isAugmentForm = maybeToBool augmentForm
562 augmentForm = getAugmentForm env arg_list
563 (Just (g',h)) = augmentForm
565 arg_list_isBuildForm = maybeToBool buildForm
566 buildForm = getBuildForm env arg_list
569 arg_list_isListForm = maybeToBool listForm
570 listForm = getListForm env arg_list
571 (Just (the_list,the_tl)) = listForm
574 arg_list_isAppendForm = maybeToBool appendForm
575 appendForm = getAppendForm env arg_list
576 (Just (xs,ys)) = appendForm
579 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
580 | doing_inlining && (isInterestingArg env arg_k
581 || isConsFun env arg_k)
587 -- (a:b) -> h b (f r a)
592 -- tick FoldrInline `thenSmpl_`
595 mkListTy ty2, -- b :: [t1]
597 mkListTy ty2, -- x :: t1
598 mkFunTys [mkListTy ty2, ty1] ty1,
599 -- h :: [t2] -> t1 -> t1
600 mkFunTys [ty1, ty2] ty1,
605 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
607 h_rhs = (Lam x (Lam r (Case (Var x))
609 [(nilDataCon,[],argToExpr (VarArg r)),
610 (consDataCon,[a,b],body)]
612 body = Let (NonRec v (App (App (Var f) (VarArg r))
614 (App (App (argToExpr (VarArg h))
620 (Lam f (Lam z (Lam xs
621 (Let (Rec [(h,h_rhs)])
622 (App (App (Var h) (VarArg xs))
624 (ValArg arg_k:rest_args))
627 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
629 foldl_fun env _ = 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 = Just (tick Str_UnpackCons `thenSmpl_`
640 returnSmpl (mkGenApp (Var unpackCStringAppendId)
644 unpack_foldr_fun env _ = Nothing
646 unpack_append_fun env
647 [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
648 | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
649 = Just (tick Str_UnpackNil `thenSmpl_`
650 returnSmpl (Lit (NoRepStr str_val))
652 unpack_append_fun env _ = Nothing