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