692209adaf8bf36ee5a80b5ed1a35c7dce4ad7b0
[ghc-hetmet.git] / ghc / compiler / simplCore / MagicUFs.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[MagicUFs]{Magic unfoldings that the simplifier knows about}
5
6 \begin{code}
7 module MagicUFs (
8         MagicUnfoldingFun,  -- absolutely abstract
9
10         mkMagicUnfoldingFun,
11         applyMagicUnfoldingFun
12     ) where
13
14 #include "HsVersions.h"
15
16 import CoreSyn
17 import SimplMonad       ( SimplM, SimplCont )
18 import Type             ( mkFunTys )
19 import TysWiredIn       ( mkListTy )
20 import Unique           ( Unique{-instances-} )
21 import Util             ( assoc, zipWith3Equal, nOfThem )
22 import Panic            ( panic )
23 \end{code}
24
25 %************************************************************************
26 %*                                                                      *
27 \subsection{Types, etc., for magic-unfolding functions}
28 %*                                                                      *
29 %************************************************************************
30
31 \begin{code}
32 data MagicUnfoldingFun
33   = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
34                                 -- Just result, or Nothing
35 \end{code}
36
37 Give us a value's @Unique@, we'll give you back the corresponding MUF.
38 \begin{code}
39 mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
40
41 mkMagicUnfoldingFun tag
42   = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
43
44 magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
45 \end{code}
46
47 Give us an MUF and stuff to apply it to, and we'll give you back the answer.
48
49 \begin{code}
50 applyMagicUnfoldingFun
51         :: MagicUnfoldingFun
52         -> SimplCont
53         -> Maybe (SimplM CoreExpr)
54
55 applyMagicUnfoldingFun (MUF fun) cont = fun cont
56 \end{code}
57
58 %************************************************************************
59 %*                                                                      *
60 \subsection{The table of actual magic unfoldings}
61 %*                                                                      *
62 %************************************************************************
63
64 \begin{code}
65 {- LATER:
66
67 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
68
69 magic_UFs_table
70   = [(SLIT("augment"),          MUF augment_fun),
71      (SLIT("build"),            MUF build_fun),
72      (SLIT("foldl"),            MUF foldl_fun),
73      (SLIT("foldr"),            MUF foldr_fun),
74      (SLIT("unpackFoldrPS__"),  MUF unpack_foldr_fun),
75      (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
76 \end{code}
77
78 %************************************************************************
79 %*                                                                      *
80 \subsubsection{Unfolding function for @append@}
81 %*                                                                      *
82 %************************************************************************
83
84 \begin{code}
85 -- First build, the way we express our lists.
86
87 build_fun :: SimplEnv
88           -> [CoreArg]
89           -> Maybe (SimplM CoreExpr)
90 build_fun env [TypeArg ty,ValArg (VarArg e)]
91   | switchIsSet env SimplDoInlineFoldrBuild
92   = Just result
93   where
94     tyL     = mkListTy ty
95     ourCons = CoTyApp (Var consDataCon) ty
96     ourNil  = CoTyApp (Var nilDataCon) ty
97
98     result = newIds  [ mkFunTys [ty, tyL] tyL, tyL ]    `thenSmpl` \ [c,n] ->
99              returnSmpl(Let (NonRec c ourCons)
100                        (Let (NonRec n ourNil)
101                        (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
102
103 -- ToDo: add `build' without an argument instance.
104 -- This is strange, because of g's type.
105 build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
106                   Nothing
107 \end{code}
108
109 \begin{code}
110 augment_fun :: SimplEnv
111           -> [CoreArg]
112           -> Maybe (SimplM CoreExpr)
113
114 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
115  | switchIsSet env SimplDoInlineFoldrBuild
116  = Just result
117  where
118    tyL     = mkListTy ty
119    ourCons = CoTyApp (Var consDataCon) ty
120    result = newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
121             returnSmpl (Let (NonRec c ourCons)
122                        (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
123 -- ToDo: add `build' without an argument instance.
124 -- This is strange, because of g's type.
125
126 augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
127                     Nothing
128 \end{code}
129
130 Now foldr, the way we consume lists.
131
132 \begin{code}
133 foldr_fun :: SimplEnv
134           -> [CoreArg]
135           -> Maybe (SimplM CoreExpr)
136
137 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
138   | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
139         -- foldr (:) [] ==> id
140         -- this transformation is *always* benificial
141         -- cf.  foldr (:) [] (build g) == g (:) []
142         -- with foldr (:) [] (build g) == build g
143         -- after unfolding build, they are the same thing.
144   = Just (tick Foldr_Cons_Nil           `thenSmpl_`
145           newId (mkListTy ty1)          `thenSmpl` \ x ->
146           returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
147     )
148  where
149    do_fb_red            = switchIsSet env SimplDoFoldrBuild
150
151 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
152  | do_fb_red && isNilForm env arg_list
153         -- foldr f z [] = z
154         -- again another short cut, helps with unroling of constant lists
155  = Just (tick Foldr_Nil `thenSmpl_`
156          returnSmpl (argToExpr arg_z)
157    )
158
159   | do_fb_red && arg_list_isBuildForm
160         -- foldr k z (build g) ==> g k z
161         -- this next line *is* the foldr/build rule proper.
162   = Just (tick FoldrBuild       `thenSmpl_`
163           returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
164     )
165
166   | do_fb_red && arg_list_isAugmentForm
167         -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
168         -- this next line *is* the foldr/augment rule proper.
169   = Just (tick FoldrAugment     `thenSmpl_`
170           newId ty2                             `thenSmpl` \ v ->
171           returnSmpl (
172                 Let (NonRec v (mkGenApp (Var foldrId)
173                                         [TypeArg ty1,TypeArg ty2,
174                                          ValArg arg_k,
175                                          ValArg arg_z,
176                                          ValArg h]))
177                 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
178     )
179
180  | do_fb_red && arg_list_isListForm
181         -- foldr k z (a:b:c:rest) =
182         --      (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
183         -- NB: 'k' is used just one by foldr, but 'f' is used many
184         -- times inside the list structure. This means that
185         -- 'f' needs to be inside a lambda, to make sure the simplifier
186         -- realises this.
187         --
188         -- The structure of
189         --       f a (f b (f c (foldr f z rest)))
190         -- in core becomes:
191         --      let ele_1 = foldr f z rest
192         --          ele_2 = f c ele_1
193         --          ele_3 = f b ele_2
194         --      in f a ele_3
195         --
196   = Just (tick Foldr_List       `thenSmpl_`
197           newIds (
198                 mkFunTys [ty1, ty2] ty2 :
199                 nOfThem (length the_list) ty2
200           )                     `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
201           let
202             fst_bind = NonRec
203                         ele_id1
204                         (mkGenApp (Var foldrId)
205                                 [TypeArg ty1,TypeArg ty2,
206                                  ValArg (VarArg f_id),
207                                  ValArg arg_z,
208                                  ValArg the_tl])
209             rest_binds = zipWith3Equal "Foldr:rest_binds"
210                          (\ e v e' -> NonRec e (mkRhs v e'))
211                          ele_ids
212                          (reverse (tail the_list))
213                          (init (ele_id1:ele_ids))
214             mkRhs v e = App (App (Var f_id) v) (VarArg e)
215             core_list = foldr
216                         Let
217                         (mkRhs (head the_list) (last (ele_id1:ele_ids)))
218                         (fst_bind:rest_binds)
219           in
220           returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
221     )
222
223
224         --
225
226  | do_fb_red && arg_list_isStringForm   -- ok, its a string!
227         -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
228  = Just (tick Str_FoldrStr                              `thenSmpl_`
229          returnSmpl (mkGenApp (Var unpackCStringFoldrId)
230                                 (TypeArg ty2:
231                                  ValArg (LitArg (MachStr str_val)):
232                                  ValArg arg_k:
233                                  ValArg arg_z:
234                                  rest_args))
235    )
236  where
237    do_fb_red            = switchIsSet env SimplDoFoldrBuild
238
239    arg_list_isStringForm = maybeToBool stringForm
240    stringForm            = getStringForm env arg_list
241    (Just str_val)        = stringForm
242
243    arg_list_isBuildForm = maybeToBool buildForm
244    buildForm            = getBuildForm env arg_list
245    (Just g)             = buildForm
246
247    arg_list_isAugmentForm  = maybeToBool augmentForm
248    augmentForm             = getAugmentForm env arg_list
249    (Just (g',h))           = augmentForm
250
251    arg_list_isListForm      = maybeToBool listForm
252    listForm                 = getListForm env arg_list
253    (Just (the_list,the_tl)) = listForm
254 {-
255    arg_list_isAppendForm = maybeToBool appendForm
256    appendForm            = getAppendForm env arg_list
257    (Just (xs,ys))        = appendForm
258 -}
259
260 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
261   | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
262        -- foldr (:) z xs = xs ++ z
263   = Just (tick Foldr_Cons       `thenSmpl_`
264            newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
265            returnSmpl (mkGenApp
266                         (Lam z (Lam x (mkGenApp
267                                         (Var appendId) [
268                                                 TypeArg ty1,
269                                                 ValArg (VarArg x),
270                                                 ValArg (VarArg z)]))
271                         rest_args))
272     )
273
274   | doing_inlining && (isInterestingArg env arg_k
275                        || isConsFun env arg_k)
276       -- foldr k args =
277       --        (\ f z xs ->
278       --          letrec
279       --             h x = case x of
280       --                    [] -> z
281       --                    (a:b) -> f a (h b)
282       --          in
283       --             h xs) k args
284       --
285 --     tick FoldrInline         `thenSmpl_`
286   = Just (newIds [
287                 ty1,                    -- a :: t1
288                 mkListTy ty1,           -- b :: [t1]
289                 ty2,                    -- v :: t2
290                 mkListTy ty1,           -- x :: t1
291                 mkFunTys [mkListTy ty1] ty2,
292                                         -- h :: [t1] -> t2
293                 mkFunTys [ty1, ty2] ty2,
294                                         -- f
295                 ty2,                    -- z
296                 mkListTy ty1            -- xs
297                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
298            let
299              h_rhs = (Lam x (Case (Var x)
300                       (AlgAlts
301                           [(nilDataCon,[],argToExpr (VarArg z)),
302                            (consDataCon,[a,b],body)]
303                        NoDefault)))
304              body = Let (NonRec v (App (Var h) (VarArg b)))
305                           (App (App (argToExpr (VarArg f))
306                                                   (VarArg a))
307                                                     (VarArg v))
308            in
309              returnSmpl (
310                      mkGenApp
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))
315     )
316    where
317      doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
318      dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
319
320 foldr_fun _ _ = Nothing
321
322 isConsFun :: SimplEnv -> CoreArg -> Bool
323 isConsFun env (VarArg v)
324   = case lookupUnfolding env v of
325         SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
326           | con == consDataCon && x==x' && y==y'
327           -> ASSERT ( length tys == 1 ) True
328         _ -> False
329 isConsFun env _ = False
330
331 isNilForm :: SimplEnv -> CoreArg -> Bool
332 isNilForm env (VarArg v)
333   = case lookupUnfolding env v of
334         SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
335         SimpleUnfolding _ (Lit (NoRepStr s))   _ | _NULL_ s           -> True
336         _                                                     -> False
337 isNilForm env _ = False
338
339 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
340 getBuildForm env (VarArg v)
341   = case lookupUnfolding env v of
342         SimpleUnfolding False _ _ _ -> Nothing
343                                         -- not allowed to inline :-(
344         SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
345           | bld == buildId -> Just g
346         SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
347                                         (VarArg g)) h) _
348           | bld == augmentId && isNilForm env h  -> Just g
349         _ -> Nothing
350 getBuildForm env _ = Nothing
351
352
353
354 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
355 getAugmentForm env (VarArg v)
356   = case lookupUnfolding env v of
357         SimpleUnfolding False _ _ _ -> Nothing
358                                 -- not allowed to inline :-(
359         SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
360                                                 (VarArg g)) h) _
361           | bld == augmentId -> Just (g,h)
362         _ -> Nothing
363 getAugmentForm env _ = Nothing
364
365 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
366 getStringForm env (LitArg (NoRepStr str)) = Just str
367 getStringForm env _ = Nothing
368
369 {-
370 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
371 getAppendForm env (VarArg v) =
372     case lookupUnfolding env v of
373         SimpleUnfolding False _ _ _ -> Nothing  -- not allowed to inline :-(
374         SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
375           | fld == foldrId && isConsFun env con -> Just (xs,ys)
376         _ -> Nothing
377 getAppendForm env _ = Nothing
378 -}
379
380 --
381 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
382 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
383 --
384
385 getListForm
386         :: SimplEnv
387         -> CoreArg
388         -> Maybe ([CoreArg],CoreArg)
389 getListForm env (VarArg v)
390   = case lookupUnfolding env v of
391        SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
392           | id == consDataCon ->
393                 case getListForm env tail of
394                    Nothing -> Just ([head],tail)
395                    Just (lst,new_tail) -> Just (head:lst,new_tail)
396        _ -> Nothing
397 getListForm env _ = Nothing
398
399 isInterestingArg :: SimplEnv -> CoreArg -> Bool
400 isInterestingArg env (VarArg v)
401   = case lookupUnfolding env v of
402        SimpleUnfolding False _ _ UnfoldNever -> False
403        SimpleUnfolding _ exp guide -> True
404        _ -> False
405 isInterestingArg env _ = False
406
407 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
408  | do_fb_red && isNilForm env arg_list
409         -- foldl f z [] = z
410         -- again another short cut, helps with unroling of constant lists
411  = Just (tick Foldl_Nil `thenSmpl_`
412          returnSmpl (argToExpr arg_z)
413    )
414
415   | do_fb_red && arg_list_isBuildForm
416         -- foldl t1 t2 k z (build t3 g) ==>
417         --                 let c {- INLINE -} = \ b g' a -> g' (f a b)
418         --                     n {- INLINE -} = \ a -> a
419         --                 in g t1 c n z
420         -- this next line *is* the foldr/build rule proper.
421   = Just(tick FoldlBuild        `thenSmpl_`
422         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
423         -- n :: t1 -> t1
424          newIds [
425           {- pre_c -}   mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
426           {- pre_n -}   mkFunTys [ty1] ty1,
427           {- b -}       ty2,
428           {- g' -}      mkFunTys [ty1] ty1,
429           {- a -}       ty1,
430           {- a' -}      ty1,
431           {- t -}       ty1
432           ]             `thenSmpl` \ [pre_c,
433                                       pre_n,
434                                       b,
435                                       g',
436                                       a,
437                                       a',
438                                       t] ->
439
440         let
441           c     = addInlinePragma pre_c
442           c_rhs = Lam b (Lam g' (Lam a
443                   (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
444                          (App (Var g') (VarArg t)))))
445           n     = addInlinePragma pre_n
446           n_rhs = Lam a' (Var a')
447         in
448         returnSmpl (Let (NonRec c c_rhs) $
449                     Let (NonRec n n_rhs) $
450                     mkGenApp (Var g) 
451                     (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
452                                 :ValArg arg_z:rest_args))
453     )
454
455   | do_fb_red && arg_list_isAugmentForm
456         -- foldl t1 t2 k z (augment t3 g h) ==>
457         --                 let c {- INLINE -} = \ b g' a -> g' (f a b)
458         --                     n {- INLINE -} = \ a -> a
459         --                     r {- INLINE -} = foldr t2 (t1 -> t1) c n h
460         --                 in g t1 c r z
461         -- this next line *is* the foldr/build rule proper.
462   = Just (tick FoldlAugment     `thenSmpl_`
463         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
464         -- n :: t1 -> t1
465           newIds [
466            {- pre_c -}  mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
467            {- pre_n -}  mkFunTys [ty1] ty1,
468            {- pre_r -}  mkFunTys [ty1] ty1,
469            {- b -}      ty2,
470            {- g_ -}     mkFunTys [ty1] ty1,
471            {- a -}      ty1,
472            {- a' -}     ty1,
473            {- t -}      ty1
474            ]            `thenSmpl` \ [pre_c,
475                                       pre_n,
476                                       pre_r,
477                                       b,
478                                       g_,
479                                       a,
480                                       a',
481                                       t] ->
482
483         let
484           c     = addInlinePragma pre_c
485           c_rhs = Lam b (Lam g_ (Lam a
486                   (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
487                          (App (Var g_) (VarArg t)))))
488           n     = addInlinePragma pre_n
489           n_rhs = Lam a' (Var a')
490           r     = addInlinePragma pre_r
491           r_rhs = mkGenApp (Var foldrId)
492                                         [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
493                                          ValArg (VarArg c),
494                                          ValArg (VarArg n),
495                                          ValArg h]
496        in
497        returnSmpl (Let (NonRec c c_rhs) $
498                    Let (NonRec n n_rhs) $
499                    Let (NonRec r r_rhs) $
500                    mkGenApp (Var g')
501                       (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
502                                 :ValArg arg_z:rest_args))
503     )
504
505  | do_fb_red && arg_list_isListForm
506         -- foldl k z (a:b:c:rest) =
507         --      (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
508         -- NB: 'k' is used just one by foldr, but 'f' is used many
509         -- times inside the list structure. This means that
510         -- 'f' needs to be inside a lambda, to make sure the simplifier
511         -- realises this.
512         --
513         -- The structure of
514         --       foldl f (f (f (f z a) b) c) rest
515         --       f a (f b (f c (foldr f z rest)))
516         -- in core becomes:
517         --      let ele_1 = f z a
518         --          ele_2 = f ele_1 b
519         --          ele_3 = f ele_2 c
520         --      in foldl f ele_3 rest
521         --
522   = Just (tick Foldl_List       `thenSmpl_`
523           newIds (
524                 mkFunTys [ty1, ty2] ty1 :
525                 nOfThem (length the_list) ty1
526           )                     `thenSmpl` \ (f_id:ele_ids) ->
527           let
528             rest_binds = zipWith3Equal "foldl:rest_binds"
529                          (\ e v e' -> NonRec e (mkRhs v e'))
530                          ele_ids                                -- :: [Id]
531                          the_list                               -- :: [CoreArg]
532                          (init (arg_z:map VarArg ele_ids))      -- :: [CoreArg]
533             mkRhs v e = App (App (Var f_id) e) v
534
535             last_bind = mkGenApp (Var foldlId)
536                                 [TypeArg ty1,TypeArg ty2,
537                                  ValArg (VarArg f_id),
538                                  ValArg (VarArg (last ele_ids)),
539                                  ValArg the_tl]
540             core_list = foldr
541                         Let
542                         last_bind
543                         rest_binds
544           in
545           returnSmpl (mkGenApp (Lam f_id core_list)
546                                       (ValArg arg_k:rest_args))
547     )
548
549  where
550    do_fb_red            = switchIsSet env SimplDoFoldrBuild
551
552    arg_list_isAugmentForm  = maybeToBool augmentForm
553    augmentForm             = getAugmentForm env arg_list
554    (Just (g',h))           = augmentForm
555
556    arg_list_isBuildForm = maybeToBool buildForm
557    buildForm            = getBuildForm env arg_list
558    (Just g)             = buildForm
559
560    arg_list_isListForm      = maybeToBool listForm
561    listForm                 = getListForm env arg_list
562    (Just (the_list,the_tl)) = listForm
563
564 {-
565    arg_list_isAppendForm = maybeToBool appendForm
566    appendForm            = getAppendForm env arg_list
567    (Just (xs,ys))        = appendForm
568 -}
569
570 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
571   | doing_inlining && (isInterestingArg env arg_k
572                        || isConsFun env arg_k)
573       -- foldl k args =
574       --        (\ f z xs ->
575       --          letrec
576       --             h x r = case x of
577       --                      []    -> r
578       --                      (a:b) -> h b (f r a)
579       --          in
580       --             h xs z) k args
581       --
582   = Just (
583 --     tick FoldrInline                         `thenSmpl_`
584      newIds [
585                 ty2,                    -- a :: t1
586                 mkListTy ty2,           -- b :: [t1]
587                 ty1,                    -- v :: t2
588                 mkListTy ty2,           -- x :: t1
589                 mkFunTys [mkListTy ty2, ty1] ty1,
590                                         -- h :: [t2] -> t1 -> t1
591                 mkFunTys [ty1, ty2] ty1,
592                                         -- f
593                 ty1,                    -- z
594                 mkListTy ty2,           -- xs
595                 ty1                     -- r
596                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
597            let
598              h_rhs = (Lam x (Lam r (Case (Var x))
599                       (AlgAlts
600                           [(nilDataCon,[],argToExpr (VarArg r)),
601                            (consDataCon,[a,b],body)]
602                        NoDefault)))
603              body = Let (NonRec v (App (App (Var f) (VarArg r))
604                                                               (VarArg a)))
605                           (App (App (argToExpr (VarArg h))
606                                                   (VarArg b))
607                                                     (VarArg v))
608            in
609              returnSmpl (
610                      (mkGenApp
611                          (Lam f (Lam z (Lam xs
612                           (Let (Rec [(h,h_rhs)])
613                                  (App (App (Var h) (VarArg xs))
614                                                          (VarArg z))))))
615                      (ValArg arg_k:rest_args))
616    )
617    where
618         doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
619
620 foldl_fun env _ =  Nothing
621 \end{code}
622
623
624 \begin{code}
625 --
626 --  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
627 --
628 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
629    | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
630    = Just (tick Str_UnpackCons          `thenSmpl_`
631            returnSmpl (mkGenApp (Var unpackCStringAppendId)
632                                 [ValArg str,
633                                  ValArg arg_z])
634      )
635 unpack_foldr_fun env _ =  Nothing
636
637 unpack_append_fun env
638         [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
639    | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
640    = Just (tick Str_UnpackNil           `thenSmpl_`
641            returnSmpl (Lit (NoRepStr str_val))
642      )
643 unpack_append_fun env _ =  Nothing
644 -}
645 \end{code}