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, panic )
  22 \end{code}
  23
  24 %************************************************************************
  25 %*                                                                      *
  26 \subsection{Types, etc., for magic-unfolding functions}
  27 %*                                                                      *
  28 %************************************************************************
  29
  30 \begin{code}
  31 data MagicUnfoldingFun
  32   = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
  33                                 -- Just result, or Nothing
  34 \end{code}
  35
  36 Give us a value's @Unique@, we'll give you back the corresponding MUF.
  37 \begin{code}
  38 mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
  39
  40 mkMagicUnfoldingFun tag
  41   = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
  42
  43 magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
  44 \end{code}
  45
  46 Give us an MUF and stuff to apply it to, and we'll give you back the answer.
  47
  48 \begin{code}
  49 applyMagicUnfoldingFun
  50         :: MagicUnfoldingFun
  51         -> SimplCont
  52         -> Maybe (SimplM CoreExpr)
  53
  54 applyMagicUnfoldingFun (MUF fun) cont = fun cont
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{The table of actual magic unfoldings}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64 {- LATER:
  65
  66 magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
  67
  68 magic_UFs_table
  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)]
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsubsection{Unfolding function for @append@}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 -- First build, the way we express our lists.
  85
  86 build_fun :: SimplEnv
  87           -> [CoreArg]
  88           -> Maybe (SimplM CoreExpr)
  89 build_fun env [TypeArg ty,ValArg (VarArg e)]
  90   | switchIsSet env SimplDoInlineFoldrBuild
  91   = Just result
  92   where
  93     tyL     = mkListTy ty
  94     ourCons = CoTyApp (Var consDataCon) ty
  95     ourNil  = CoTyApp (Var nilDataCon) ty
  96
  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)))
 101
 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))
 105                   Nothing
 106 \end{code}
 107
 108 \begin{code}
 109 augment_fun :: SimplEnv
 110           -> [CoreArg]
 111           -> Maybe (SimplM CoreExpr)
 112
 113 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
 114  | switchIsSet env SimplDoInlineFoldrBuild
 115  = Just result
 116  where
 117    tyL     = mkListTy ty
 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.
 124
 125 augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
 126                     Nothing
 127 \end{code}
 128
 129 Now foldr, the way we consume lists.
 130
 131 \begin{code}
 132 foldr_fun :: SimplEnv
 133           -> [CoreArg]
 134           -> Maybe (SimplM CoreExpr)
 135
 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))
 146     )
 147  where
 148    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 149
 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
 152         -- foldr f z [] = z
 153         -- again another short cut, helps with unroling of constant lists
 154  = Just (tick Foldr_Nil `thenSmpl_`
 155          returnSmpl (argToExpr arg_z)
 156    )
 157
 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))
 163     )
 164
 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 ->
 170           returnSmpl (
 171                 Let (NonRec v (mkGenApp (Var foldrId)
 172                                         [TypeArg ty1,TypeArg ty2,
 173                                          ValArg arg_k,
 174                                          ValArg arg_z,
 175                                          ValArg h]))
 176                 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
 177     )
 178
 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
 185         -- realises this.
 186         --
 187         -- The structure of
 188         --       f a (f b (f c (foldr f z rest)))
 189         -- in core becomes:
 190         --      let ele_1 = foldr f z rest
 191         --          ele_2 = f c ele_1
 192         --          ele_3 = f b ele_2
 193         --      in f a ele_3
 194         --
 195   = Just (tick Foldr_List       `thenSmpl_`
 196           newIds (
 197                 mkFunTys [ty1, ty2] ty2 :
 198                 nOfThem (length the_list) ty2
 199           )                     `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
 200           let
 201             fst_bind = NonRec
 202                         ele_id1
 203                         (mkGenApp (Var foldrId)
 204                                 [TypeArg ty1,TypeArg ty2,
 205                                  ValArg (VarArg f_id),
 206                                  ValArg arg_z,
 207                                  ValArg the_tl])
 208             rest_binds = zipWith3Equal "Foldr:rest_binds"
 209                          (\ e v e' -> NonRec e (mkRhs v e'))
 210                          ele_ids
 211                          (reverse (tail the_list))
 212                          (init (ele_id1:ele_ids))
 213             mkRhs v e = App (App (Var f_id) v) (VarArg e)
 214             core_list = foldr
 215                         Let
 216                         (mkRhs (head the_list) (last (ele_id1:ele_ids)))
 217                         (fst_bind:rest_binds)
 218           in
 219           returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
 220     )
 221
 222
 223         --
 224
 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)
 229                                 (TypeArg ty2:
 230                                  ValArg (LitArg (MachStr str_val)):
 231                                  ValArg arg_k:
 232                                  ValArg arg_z:
 233                                  rest_args))
 234    )
 235  where
 236    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 237
 238    arg_list_isStringForm = maybeToBool stringForm
 239    stringForm            = getStringForm env arg_list
 240    (Just str_val)        = stringForm
 241
 242    arg_list_isBuildForm = maybeToBool buildForm
 243    buildForm            = getBuildForm env arg_list
 244    (Just g)             = buildForm
 245
 246    arg_list_isAugmentForm  = maybeToBool augmentForm
 247    augmentForm             = getAugmentForm env arg_list
 248    (Just (g',h))           = augmentForm
 249
 250    arg_list_isListForm      = maybeToBool listForm
 251    listForm                 = getListForm env arg_list
 252    (Just (the_list,the_tl)) = listForm
 253 {-
 254    arg_list_isAppendForm = maybeToBool appendForm
 255    appendForm            = getAppendForm env arg_list
 256    (Just (xs,ys))        = appendForm
 257 -}
 258
 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] ->
 264            returnSmpl (mkGenApp
 265                         (Lam z (Lam x (mkGenApp
 266                                         (Var appendId) [
 267                                                 TypeArg ty1,
 268                                                 ValArg (VarArg x),
 269                                                 ValArg (VarArg z)]))
 270                         rest_args))
 271     )
 272
 273   | doing_inlining && (isInterestingArg env arg_k
 274                        || isConsFun env arg_k)
 275       -- foldr k args =
 276       --        (\ f z xs ->
 277       --          letrec
 278       --             h x = case x of
 279       --                    [] -> z
 280       --                    (a:b) -> f a (h b)
 281       --          in
 282       --             h xs) k args
 283       --
 284 --     tick FoldrInline         `thenSmpl_`
 285   = Just (newIds [
 286                 ty1,                    -- a :: t1
 287                 mkListTy ty1,           -- b :: [t1]
 288                 ty2,                    -- v :: t2
 289                 mkListTy ty1,           -- x :: t1
 290                 mkFunTys [mkListTy ty1] ty2,
 291                                         -- h :: [t1] -> t2
 292                 mkFunTys [ty1, ty2] ty2,
 293                                         -- f
 294                 ty2,                    -- z
 295                 mkListTy ty1            -- xs
 296                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
 297            let
 298              h_rhs = (Lam x (Case (Var x)
 299                       (AlgAlts
 300                           [(nilDataCon,[],argToExpr (VarArg z)),
 301                            (consDataCon,[a,b],body)]
 302                        NoDefault)))
 303              body = Let (NonRec v (App (Var h) (VarArg b)))
 304                           (App (App (argToExpr (VarArg f))
 305                                                   (VarArg a))
 306                                                     (VarArg v))
 307            in
 308              returnSmpl (
 309                      mkGenApp
 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))
 314     )
 315    where
 316      doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 317      dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
 318
 319 foldr_fun _ _ = Nothing
 320
 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
 327         _ -> False
 328 isConsFun env _ = False
 329
 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
 335         _                                                     -> False
 336 isNilForm env _ = False
 337
 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) _)
 346                                         (VarArg g)) h) _
 347           | bld == augmentId && isNilForm env h  -> Just g
 348         _ -> Nothing
 349 getBuildForm env _ = Nothing
 350
 351
 352
 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) _)
 359                                                 (VarArg g)) h) _
 360           | bld == augmentId -> Just (g,h)
 361         _ -> Nothing
 362 getAugmentForm env _ = Nothing
 363
 364 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
 365 getStringForm env (LitArg (NoRepStr str)) = Just str
 366 getStringForm env _ = Nothing
 367
 368 {-
 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)
 375         _ -> Nothing
 376 getAppendForm env _ = Nothing
 377 -}
 378
 379 --
 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 = []
 382 --
 383
 384 getListForm
 385         :: SimplEnv
 386         -> CoreArg
 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)
 395        _ -> Nothing
 396 getListForm env _ = Nothing
 397
 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
 403        _ -> False
 404 isInterestingArg env _ = False
 405
 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
 408         -- foldl f z [] = z
 409         -- again another short cut, helps with unroling of constant lists
 410  = Just (tick Foldl_Nil `thenSmpl_`
 411          returnSmpl (argToExpr arg_z)
 412    )
 413
 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
 418         --                 in g t1 c n z
 419         -- this next line *is* the foldr/build rule proper.
 420   = Just(tick FoldlBuild        `thenSmpl_`
 421         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
 422         -- n :: t1 -> t1
 423          newIds [
 424           {- pre_c -}   mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
 425           {- pre_n -}   mkFunTys [ty1] ty1,
 426           {- b -}       ty2,
 427           {- g' -}      mkFunTys [ty1] ty1,
 428           {- a -}       ty1,
 429           {- a' -}      ty1,
 430           {- t -}       ty1
 431           ]             `thenSmpl` \ [pre_c,
 432                                       pre_n,
 433                                       b,
 434                                       g',
 435                                       a,
 436                                       a',
 437                                       t] ->
 438
 439         let
 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')
 446         in
 447         returnSmpl (Let (NonRec c c_rhs) $
 448                     Let (NonRec n n_rhs) $
 449                     mkGenApp (Var g)
 450                     (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
 451                                 :ValArg arg_z:rest_args))
 452     )
 453
 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
 459         --                 in g t1 c r z
 460         -- this next line *is* the foldr/build rule proper.
 461   = Just (tick FoldlAugment     `thenSmpl_`
 462         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
 463         -- n :: t1 -> t1
 464           newIds [
 465            {- pre_c -}  mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
 466            {- pre_n -}  mkFunTys [ty1] ty1,
 467            {- pre_r -}  mkFunTys [ty1] ty1,
 468            {- b -}      ty2,
 469            {- g_ -}     mkFunTys [ty1] ty1,
 470            {- a -}      ty1,
 471            {- a' -}     ty1,
 472            {- t -}      ty1
 473            ]            `thenSmpl` \ [pre_c,
 474                                       pre_n,
 475                                       pre_r,
 476                                       b,
 477                                       g_,
 478                                       a,
 479                                       a',
 480                                       t] ->
 481
 482         let
 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),
 492                                          ValArg (VarArg c),
 493                                          ValArg (VarArg n),
 494                                          ValArg h]
 495        in
 496        returnSmpl (Let (NonRec c c_rhs) $
 497                    Let (NonRec n n_rhs) $
 498                    Let (NonRec r r_rhs) $
 499                    mkGenApp (Var g')
 500                       (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
 501                                 :ValArg arg_z:rest_args))
 502     )
 503
 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
 510         -- realises this.
 511         --
 512         -- The structure of
 513         --       foldl f (f (f (f z a) b) c) rest
 514         --       f a (f b (f c (foldr f z rest)))
 515         -- in core becomes:
 516         --      let ele_1 = f z a
 517         --          ele_2 = f ele_1 b
 518         --          ele_3 = f ele_2 c
 519         --      in foldl f ele_3 rest
 520         --
 521   = Just (tick Foldl_List       `thenSmpl_`
 522           newIds (
 523                 mkFunTys [ty1, ty2] ty1 :
 524                 nOfThem (length the_list) ty1
 525           )                     `thenSmpl` \ (f_id:ele_ids) ->
 526           let
 527             rest_binds = zipWith3Equal "foldl:rest_binds"
 528                          (\ e v e' -> NonRec e (mkRhs v e'))
 529                          ele_ids                                -- :: [Id]
 530                          the_list                               -- :: [CoreArg]
 531                          (init (arg_z:map VarArg ele_ids))      -- :: [CoreArg]
 532             mkRhs v e = App (App (Var f_id) e) v
 533
 534             last_bind = mkGenApp (Var foldlId)
 535                                 [TypeArg ty1,TypeArg ty2,
 536                                  ValArg (VarArg f_id),
 537                                  ValArg (VarArg (last ele_ids)),
 538                                  ValArg the_tl]
 539             core_list = foldr
 540                         Let
 541                         last_bind
 542                         rest_binds
 543           in
 544           returnSmpl (mkGenApp (Lam f_id core_list)
 545                                       (ValArg arg_k:rest_args))
 546     )
 547
 548  where
 549    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 550
 551    arg_list_isAugmentForm  = maybeToBool augmentForm
 552    augmentForm             = getAugmentForm env arg_list
 553    (Just (g',h))           = augmentForm
 554
 555    arg_list_isBuildForm = maybeToBool buildForm
 556    buildForm            = getBuildForm env arg_list
 557    (Just g)             = buildForm
 558
 559    arg_list_isListForm      = maybeToBool listForm
 560    listForm                 = getListForm env arg_list
 561    (Just (the_list,the_tl)) = listForm
 562
 563 {-
 564    arg_list_isAppendForm = maybeToBool appendForm
 565    appendForm            = getAppendForm env arg_list
 566    (Just (xs,ys))        = appendForm
 567 -}
 568
 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)
 572       -- foldl k args =
 573       --        (\ f z xs ->
 574       --          letrec
 575       --             h x r = case x of
 576       --                      []    -> r
 577       --                      (a:b) -> h b (f r a)
 578       --          in
 579       --             h xs z) k args
 580       --
 581   = Just (
 582 --     tick FoldrInline                         `thenSmpl_`
 583      newIds [
 584                 ty2,                    -- a :: t1
 585                 mkListTy ty2,           -- b :: [t1]
 586                 ty1,                    -- v :: t2
 587                 mkListTy ty2,           -- x :: t1
 588                 mkFunTys [mkListTy ty2, ty1] ty1,
 589                                         -- h :: [t2] -> t1 -> t1
 590                 mkFunTys [ty1, ty2] ty1,
 591                                         -- f
 592                 ty1,                    -- z
 593                 mkListTy ty2,           -- xs
 594                 ty1                     -- r
 595                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
 596            let
 597              h_rhs = (Lam x (Lam r (Case (Var x))
 598                       (AlgAlts
 599                           [(nilDataCon,[],argToExpr (VarArg r)),
 600                            (consDataCon,[a,b],body)]
 601                        NoDefault)))
 602              body = Let (NonRec v (App (App (Var f) (VarArg r))
 603                                                               (VarArg a)))
 604                           (App (App (argToExpr (VarArg h))
 605                                                   (VarArg b))
 606                                                     (VarArg v))
 607            in
 608              returnSmpl (
 609                      (mkGenApp
 610                          (Lam f (Lam z (Lam xs
 611                           (Let (Rec [(h,h_rhs)])
 612                                  (App (App (Var h) (VarArg xs))
 613                                                          (VarArg z))))))
 614                      (ValArg arg_k:rest_args))
 615    )
 616    where
 617         doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 618
 619 foldl_fun env _ =  Nothing
 620 \end{code}
 621
 622
 623 \begin{code}
 624 --
 625 --  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
 626 --
 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)
 631                                 [ValArg str,
 632                                  ValArg arg_z])
 633      )
 634 unpack_foldr_fun env _ =  Nothing
 635
 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))
 641      )
 642 unpack_append_fun env _ =  Nothing
 643 -}
 644 \end{code}