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