2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MagicUFs]{Magic unfoldings that the simplifier knows about}
8 MagicUnfoldingFun, -- absolutely abstract
11 applyMagicUnfoldingFun
14 #include "HsVersions.h"
17 import SimplMonad ( SimplM, SimplCont )
18 import Type ( mkFunTys )
19 import TysWiredIn ( mkListTy )
20 import Unique ( Unique{-instances-} )
21 import Util ( assoc, zipWith3Equal, nOfThem, panic )
24 %************************************************************************
26 \subsection{Types, etc., for magic-unfolding functions}
28 %************************************************************************
31 data MagicUnfoldingFun
32 = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
33 -- Just result, or Nothing
36 Give us a value's @Unique@, we'll give you back the corresponding MUF.
38 mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
40 mkMagicUnfoldingFun tag
41 = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
43 magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
46 Give us an MUF and stuff to apply it to, and we'll give you back the answer.
49 applyMagicUnfoldingFun
52 -> Maybe (SimplM CoreExpr)
54 applyMagicUnfoldingFun (MUF fun) cont = fun cont
57 %************************************************************************
59 \subsection{The table of actual magic unfoldings}
61 %************************************************************************
66 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
69 = [(SLIT("augment"), MUF augment_fun),
70 (SLIT("build"), MUF build_fun),
71 (SLIT("foldl"), MUF foldl_fun),
72 (SLIT("foldr"), MUF foldr_fun),
73 (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun),
74 (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
77 %************************************************************************
79 \subsubsection{Unfolding function for @append@}
81 %************************************************************************
84 -- First build, the way we express our lists.
88 -> Maybe (SimplM CoreExpr)
89 build_fun env [TypeArg ty,ValArg (VarArg e)]
90 | switchIsSet env SimplDoInlineFoldrBuild
94 ourCons = CoTyApp (Var consDataCon) ty
95 ourNil = CoTyApp (Var nilDataCon) ty
97 result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
98 returnSmpl(Let (NonRec c ourCons)
99 (Let (NonRec n ourNil)
100 (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
102 -- ToDo: add `build' without an argument instance.
103 -- This is strange, because of g's type.
104 build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
109 augment_fun :: SimplEnv
111 -> Maybe (SimplM CoreExpr)
113 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
114 | switchIsSet env SimplDoInlineFoldrBuild
118 ourCons = CoTyApp (Var consDataCon) ty
119 result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
120 returnSmpl (Let (NonRec c ourCons)
121 (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
122 -- ToDo: add `build' without an argument instance.
123 -- This is strange, because of g's type.
125 augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
129 Now foldr, the way we consume lists.
132 foldr_fun :: SimplEnv
134 -> Maybe (SimplM CoreExpr)
136 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
137 | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
138 -- foldr (:) [] ==> id
139 -- this transformation is *always* benificial
140 -- cf. foldr (:) [] (build g) == g (:) []
141 -- with foldr (:) [] (build g) == build g
142 -- after unfolding build, they are the same thing.
143 = Just (tick Foldr_Cons_Nil `thenSmpl_`
144 newId (mkListTy ty1) `thenSmpl` \ x ->
145 returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
148 do_fb_red = switchIsSet env SimplDoFoldrBuild
150 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
151 | do_fb_red && isNilForm env arg_list
153 -- again another short cut, helps with unroling of constant lists
154 = Just (tick Foldr_Nil `thenSmpl_`
155 returnSmpl (argToExpr arg_z)
158 | do_fb_red && arg_list_isBuildForm
159 -- foldr k z (build g) ==> g k z
160 -- this next line *is* the foldr/build rule proper.
161 = Just (tick FoldrBuild `thenSmpl_`
162 returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
165 | do_fb_red && arg_list_isAugmentForm
166 -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
167 -- this next line *is* the foldr/augment rule proper.
168 = Just (tick FoldrAugment `thenSmpl_`
169 newId ty2 `thenSmpl` \ v ->
171 Let (NonRec v (mkGenApp (Var foldrId)
172 [TypeArg ty1,TypeArg ty2,
176 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
179 | do_fb_red && arg_list_isListForm
180 -- foldr k z (a:b:c:rest) =
181 -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
182 -- NB: 'k' is used just one by foldr, but 'f' is used many
183 -- times inside the list structure. This means that
184 -- 'f' needs to be inside a lambda, to make sure the simplifier
188 -- f a (f b (f c (foldr f z rest)))
190 -- let ele_1 = foldr f z rest
195 = Just (tick Foldr_List `thenSmpl_`
197 mkFunTys [ty1, ty2] ty2 :
198 nOfThem (length the_list) ty2
199 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
203 (mkGenApp (Var foldrId)
204 [TypeArg ty1,TypeArg ty2,
205 ValArg (VarArg f_id),
208 rest_binds = zipWith3Equal "Foldr:rest_binds"
209 (\ e v e' -> NonRec e (mkRhs v e'))
211 (reverse (tail the_list))
212 (init (ele_id1:ele_ids))
213 mkRhs v e = App (App (Var f_id) v) (VarArg e)
216 (mkRhs (head the_list) (last (ele_id1:ele_ids)))
217 (fst_bind:rest_binds)
219 returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
225 | do_fb_red && arg_list_isStringForm -- ok, its a string!
226 -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
227 = Just (tick Str_FoldrStr `thenSmpl_`
228 returnSmpl (mkGenApp (Var unpackCStringFoldrId)
230 ValArg (LitArg (MachStr str_val)):
236 do_fb_red = switchIsSet env SimplDoFoldrBuild
238 arg_list_isStringForm = maybeToBool stringForm
239 stringForm = getStringForm env arg_list
240 (Just str_val) = stringForm
242 arg_list_isBuildForm = maybeToBool buildForm
243 buildForm = getBuildForm env arg_list
246 arg_list_isAugmentForm = maybeToBool augmentForm
247 augmentForm = getAugmentForm env arg_list
248 (Just (g',h)) = augmentForm
250 arg_list_isListForm = maybeToBool listForm
251 listForm = getListForm env arg_list
252 (Just (the_list,the_tl)) = listForm
254 arg_list_isAppendForm = maybeToBool appendForm
255 appendForm = getAppendForm env arg_list
256 (Just (xs,ys)) = appendForm
259 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
260 | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
261 -- foldr (:) z xs = xs ++ z
262 = Just (tick Foldr_Cons `thenSmpl_`
263 newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
265 (Lam z (Lam x (mkGenApp
273 | doing_inlining && (isInterestingArg env arg_k
274 || isConsFun env arg_k)
280 -- (a:b) -> f a (h b)
284 -- tick FoldrInline `thenSmpl_`
287 mkListTy ty1, -- b :: [t1]
289 mkListTy ty1, -- x :: t1
290 mkFunTys [mkListTy ty1] ty2,
292 mkFunTys [ty1, ty2] ty2,
296 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
298 h_rhs = (Lam x (Case (Var x)
300 [(nilDataCon,[],argToExpr (VarArg z)),
301 (consDataCon,[a,b],body)]
303 body = Let (NonRec v (App (Var h) (VarArg b)))
304 (App (App (argToExpr (VarArg f))
310 (Lam f (Lam z (Lam xs
311 (Let (Rec [(h,h_rhs)])
312 (App (Var h) (VarArg xs))))))
313 (ValArg arg_k:rest_args))
316 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
317 dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
319 foldr_fun _ _ = Nothing
321 isConsFun :: SimplEnv -> CoreArg -> Bool
322 isConsFun env (VarArg v)
323 = case lookupUnfolding env v of
324 SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
325 | con == consDataCon && x==x' && y==y'
326 -> ASSERT ( length tys == 1 ) True
328 isConsFun env _ = False
330 isNilForm :: SimplEnv -> CoreArg -> Bool
331 isNilForm env (VarArg v)
332 = case lookupUnfolding env v of
333 SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
334 SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
336 isNilForm env _ = False
338 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
339 getBuildForm env (VarArg v)
340 = case lookupUnfolding env v of
341 SimpleUnfolding False _ _ _ -> Nothing
342 -- not allowed to inline :-(
343 SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
344 | bld == buildId -> Just g
345 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
347 | bld == augmentId && isNilForm env h -> Just g
349 getBuildForm env _ = Nothing
353 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
354 getAugmentForm env (VarArg v)
355 = case lookupUnfolding env v of
356 SimpleUnfolding False _ _ _ -> Nothing
357 -- not allowed to inline :-(
358 SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
360 | bld == augmentId -> Just (g,h)
362 getAugmentForm env _ = Nothing
364 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
365 getStringForm env (LitArg (NoRepStr str)) = Just str
366 getStringForm env _ = Nothing
369 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
370 getAppendForm env (VarArg v) =
371 case lookupUnfolding env v of
372 SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
373 SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
374 | fld == foldrId && isConsFun env con -> Just (xs,ys)
376 getAppendForm env _ = Nothing
380 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
381 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
387 -> Maybe ([CoreArg],CoreArg)
388 getListForm env (VarArg v)
389 = case lookupUnfolding env v of
390 SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
391 | id == consDataCon ->
392 case getListForm env tail of
393 Nothing -> Just ([head],tail)
394 Just (lst,new_tail) -> Just (head:lst,new_tail)
396 getListForm env _ = Nothing
398 isInterestingArg :: SimplEnv -> CoreArg -> Bool
399 isInterestingArg env (VarArg v)
400 = case lookupUnfolding env v of
401 SimpleUnfolding False _ _ UnfoldNever -> False
402 SimpleUnfolding _ exp guide -> True
404 isInterestingArg env _ = False
406 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
407 | do_fb_red && isNilForm env arg_list
409 -- again another short cut, helps with unroling of constant lists
410 = Just (tick Foldl_Nil `thenSmpl_`
411 returnSmpl (argToExpr arg_z)
414 | do_fb_red && arg_list_isBuildForm
415 -- foldl t1 t2 k z (build t3 g) ==>
416 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
417 -- n {- INLINE -} = \ a -> a
419 -- this next line *is* the foldr/build rule proper.
420 = Just(tick FoldlBuild `thenSmpl_`
421 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
424 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
425 {- pre_n -} mkFunTys [ty1] ty1,
427 {- g' -} mkFunTys [ty1] ty1,
431 ] `thenSmpl` \ [pre_c,
440 c = addInlinePragma pre_c
441 c_rhs = Lam b (Lam g' (Lam a
442 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
443 (App (Var g') (VarArg t)))))
444 n = addInlinePragma pre_n
445 n_rhs = Lam a' (Var a')
447 returnSmpl (Let (NonRec c c_rhs) $
448 Let (NonRec n n_rhs) $
450 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
451 :ValArg arg_z:rest_args))
454 | do_fb_red && arg_list_isAugmentForm
455 -- foldl t1 t2 k z (augment t3 g h) ==>
456 -- let c {- INLINE -} = \ b g' a -> g' (f a b)
457 -- n {- INLINE -} = \ a -> a
458 -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
460 -- this next line *is* the foldr/build rule proper.
461 = Just (tick FoldlAugment `thenSmpl_`
462 -- c :: t2 -> (t1 -> t1) -> t1 -> t1
465 {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
466 {- pre_n -} mkFunTys [ty1] ty1,
467 {- pre_r -} mkFunTys [ty1] ty1,
469 {- g_ -} mkFunTys [ty1] ty1,
473 ] `thenSmpl` \ [pre_c,
483 c = addInlinePragma pre_c
484 c_rhs = Lam b (Lam g_ (Lam a
485 (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
486 (App (Var g_) (VarArg t)))))
487 n = addInlinePragma pre_n
488 n_rhs = Lam a' (Var a')
489 r = addInlinePragma pre_r
490 r_rhs = mkGenApp (Var foldrId)
491 [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
496 returnSmpl (Let (NonRec c c_rhs) $
497 Let (NonRec n n_rhs) $
498 Let (NonRec r r_rhs) $
500 (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
501 :ValArg arg_z:rest_args))
504 | do_fb_red && arg_list_isListForm
505 -- foldl k z (a:b:c:rest) =
506 -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
507 -- NB: 'k' is used just one by foldr, but 'f' is used many
508 -- times inside the list structure. This means that
509 -- 'f' needs to be inside a lambda, to make sure the simplifier
513 -- foldl f (f (f (f z a) b) c) rest
514 -- f a (f b (f c (foldr f z rest)))
519 -- in foldl f ele_3 rest
521 = Just (tick Foldl_List `thenSmpl_`
523 mkFunTys [ty1, ty2] ty1 :
524 nOfThem (length the_list) ty1
525 ) `thenSmpl` \ (f_id:ele_ids) ->
527 rest_binds = zipWith3Equal "foldl:rest_binds"
528 (\ e v e' -> NonRec e (mkRhs v e'))
530 the_list -- :: [CoreArg]
531 (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
532 mkRhs v e = App (App (Var f_id) e) v
534 last_bind = mkGenApp (Var foldlId)
535 [TypeArg ty1,TypeArg ty2,
536 ValArg (VarArg f_id),
537 ValArg (VarArg (last ele_ids)),
544 returnSmpl (mkGenApp (Lam f_id core_list)
545 (ValArg arg_k:rest_args))
549 do_fb_red = switchIsSet env SimplDoFoldrBuild
551 arg_list_isAugmentForm = maybeToBool augmentForm
552 augmentForm = getAugmentForm env arg_list
553 (Just (g',h)) = augmentForm
555 arg_list_isBuildForm = maybeToBool buildForm
556 buildForm = getBuildForm env arg_list
559 arg_list_isListForm = maybeToBool listForm
560 listForm = getListForm env arg_list
561 (Just (the_list,the_tl)) = listForm
564 arg_list_isAppendForm = maybeToBool appendForm
565 appendForm = getAppendForm env arg_list
566 (Just (xs,ys)) = appendForm
569 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
570 | doing_inlining && (isInterestingArg env arg_k
571 || isConsFun env arg_k)
577 -- (a:b) -> h b (f r a)
582 -- tick FoldrInline `thenSmpl_`
585 mkListTy ty2, -- b :: [t1]
587 mkListTy ty2, -- x :: t1
588 mkFunTys [mkListTy ty2, ty1] ty1,
589 -- h :: [t2] -> t1 -> t1
590 mkFunTys [ty1, ty2] ty1,
595 ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
597 h_rhs = (Lam x (Lam r (Case (Var x))
599 [(nilDataCon,[],argToExpr (VarArg r)),
600 (consDataCon,[a,b],body)]
602 body = Let (NonRec v (App (App (Var f) (VarArg r))
604 (App (App (argToExpr (VarArg h))
610 (Lam f (Lam z (Lam xs
611 (Let (Rec [(h,h_rhs)])
612 (App (App (Var h) (VarArg xs))
614 (ValArg arg_k:rest_args))
617 doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
619 foldl_fun env _ = Nothing
625 -- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
627 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
628 | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
629 = Just (tick Str_UnpackCons `thenSmpl_`
630 returnSmpl (mkGenApp (Var unpackCStringAppendId)
634 unpack_foldr_fun env _ = Nothing
636 unpack_append_fun env
637 [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
638 | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
639 = Just (tick Str_UnpackNil `thenSmpl_`
640 returnSmpl (Lit (NoRepStr str_val))
642 unpack_append_fun env _ = Nothing