ghc/compiler/simplCore/MagicUFs.lhs

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