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 import Ubiq{-uitous-}
  17 import IdLoop           -- paranoia checking
  18
  19 import CoreSyn
  20 import PrelInfo         ( mkListTy )
  21 import SimplEnv         ( SimplEnv )
  22 import SimplMonad       ( SmplM(..), SimplCount )
  23 import Type             ( mkFunTys )
  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         -> SmplM (Maybe 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         -> SmplM (Maybe 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           -> SmplM (Maybe CoreExpr)
  98 build_fun env [TypeArg ty,ValArg (VarArg e)]
  99         | switchIsSet env SimplDoInlineFoldrBuild =
 100         let
 101                 tyL     = mkListTy ty
 102                 ourCons = CoTyApp (Var consDataCon) ty
 103                 ourNil  = CoTyApp (Var nilDataCon) ty
 104         in
 105         newIds  [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
 106         returnSmpl(Just (Let (NonRec c ourCons)
 107                         (Let (NonRec n ourNil)
 108                          (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
 109 -- ToDo: add `build' without an argument instance.
 110 -- This is strange, because of g's type.
 111 build_fun env _ =
 112         ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
 113         returnSmpl Nothing
 114 \end{code}
 115
 116 \begin{code}
 117 augment_fun :: SimplEnv
 118           -> [CoreArg]
 119           -> SmplM (Maybe CoreExpr)
 120
 121 augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
 122         | switchIsSet env SimplDoInlineFoldrBuild =
 123         let
 124                 tyL     = mkListTy ty
 125                 ourCons = CoTyApp (Var consDataCon) ty
 126         in
 127         newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
 128         returnSmpl (Just (Let (NonRec c ourCons)
 129                          (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
 130 -- ToDo: add `build' without an argument instance.
 131 -- This is strange, because of g's type.
 132 augment_fun env _ =
 133         ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
 134         returnSmpl Nothing
 135 \end{code}
 136
 137 Now foldr, the way we consume lists.
 138
 139 \begin{code}
 140 foldr_fun :: SimplEnv
 141           -> [CoreArg]
 142           -> SmplM (Maybe CoreExpr)
 143
 144 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
 145   | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
 146   =     -- foldr (:) [] ==> id
 147         -- this transformation is *always* benificial
 148         -- cf.  foldr (:) [] (build g) == g (:) []
 149         -- with foldr (:) [] (build g) == build g
 150         -- after unfolding build, they are the same thing.
 151      tick Foldr_Cons_Nil                `thenSmpl_`
 152      newId (mkListTy ty1)               `thenSmpl` \ x ->
 153      returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
 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     tick Foldr_Nil      `thenSmpl_`
 162     returnSmpl (Just (argToExpr arg_z))
 163
 164   | do_fb_red && arg_list_isBuildForm
 165   =     -- foldr k z (build g) ==> g k z
 166         -- this next line *is* the foldr/build rule proper.
 167     tick FoldrBuild     `thenSmpl_`
 168     returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
 169
 170   | do_fb_red && arg_list_isAugmentForm
 171   =     -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
 172         -- this next line *is* the foldr/augment rule proper.
 173     tick FoldrAugment   `thenSmpl_`
 174     newId ty2                           `thenSmpl` \ v ->
 175     returnSmpl (Just
 176                 (Let (NonRec v (mkGenApp (Var foldrId)
 177                                         [TypeArg ty1,TypeArg ty2,
 178                                          ValArg arg_k,
 179                                          ValArg arg_z,
 180                                          ValArg h]))
 181                 (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
 182
 183  | do_fb_red && arg_list_isListForm
 184  =      -- foldr k z (a:b:c:rest) =
 185         --      (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
 186         -- NB: 'k' is used just one by foldr, but 'f' is used many
 187         -- times inside the list structure. This means that
 188         -- 'f' needs to be inside a lambda, to make sure the simplifier
 189         -- realises this.
 190         --
 191         -- The structure of
 192         --       f a (f b (f c (foldr f z rest)))
 193         -- in core becomes:
 194         --      let ele_1 = foldr f z rest
 195         --          ele_2 = f c ele_1
 196         --          ele_3 = f b ele_2
 197         --      in f a ele_3
 198         --
 199   tick Foldr_List       `thenSmpl_`
 200   newIds (
 201                 mkFunTys [ty1, ty2] ty2 :
 202                 nOfThem (length the_list) ty2
 203         )                       `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
 204   let
 205         fst_bind = NonRec
 206                         ele_id1
 207                         (mkGenApp (Var foldrId)
 208                                 [TypeArg ty1,TypeArg ty2,
 209                                  ValArg (VarArg f_id),
 210                                  ValArg arg_z,
 211                                  ValArg the_tl])
 212         rest_binds = zipWith3Equal "Foldr:rest_binds"
 213                          (\ e v e' -> NonRec e (mkRhs v e'))
 214                          ele_ids
 215                          (reverse (tail the_list))
 216                          (init (ele_id1:ele_ids))
 217         mkRhs v e = App (App (Var f_id) v) (VarArg e)
 218         core_list = foldr
 219                         Let
 220                         (mkRhs (head the_list) (last (ele_id1:ele_ids)))
 221                         (fst_bind:rest_binds)
 222   in
 223         returnSmpl (Just (mkGenApp (Lam f_id core_list)
 224                                       (ValArg arg_k:rest_args)))
 225
 226
 227         --
 228
 229  | do_fb_red && arg_list_isStringForm   -- ok, its a string!
 230         -- foldr f z "foo" => unpackFoldrPS# f z "foo"#
 231    = tick Str_FoldrStr                          `thenSmpl_`
 232      returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
 233                                 (TypeArg ty2:
 234                                  ValArg (LitArg (MachStr str_val)):
 235                                  ValArg arg_k:
 236                                  ValArg arg_z:
 237                                  rest_args)))
 238  where
 239    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 240
 241    arg_list_isStringForm = maybeToBool stringForm
 242    stringForm            = getStringForm env arg_list
 243    (Just str_val)        = stringForm
 244
 245    arg_list_isBuildForm = maybeToBool buildForm
 246    buildForm            = getBuildForm env arg_list
 247    (Just g)             = buildForm
 248
 249    arg_list_isAugmentForm  = maybeToBool augmentForm
 250    augmentForm             = getAugmentForm env arg_list
 251    (Just (g',h))           = augmentForm
 252
 253    arg_list_isListForm      = maybeToBool listForm
 254    listForm                 = getListForm env arg_list
 255    (Just (the_list,the_tl)) = listForm
 256 {-
 257    arg_list_isAppendForm = maybeToBool appendForm
 258    appendForm            = getAppendForm env arg_list
 259    (Just (xs,ys))        = appendForm
 260 -}
 261
 262 foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
 263   | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
 264   =    -- foldr (:) z xs = xs ++ z
 265      tick Foldr_Cons    `thenSmpl_`
 266      newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
 267      returnSmpl (Just (mkGenApp
 268                         (Lam z (Lam x (mkGenApp
 269                                         (Var appendId) [
 270                                                 TypeArg ty1,
 271                                                 ValArg (VarArg x),
 272                                                 ValArg (VarArg z)])))
 273                         rest_args))
 274   | doing_inlining && (isInterestingArg env arg_k
 275                        || isConsFun env arg_k)
 276   =   -- foldr k args =
 277       --        (\ f z xs ->
 278       --          letrec
 279       --             h x = case x of
 280       --                    [] -> z
 281       --                    (a:b) -> f a (h b)
 282       --          in
 283       --             h xs) k args
 284       --
 285 --     tick FoldrInline         `thenSmpl_`
 286      newIds [
 287                 ty1,                    -- a :: t1
 288                 mkListTy ty1,           -- b :: [t1]
 289                 ty2,                    -- v :: t2
 290                 mkListTy ty1,           -- x :: t1
 291                 mkFunTys [mkListTy ty1] ty2,
 292                                         -- h :: [t1] -> t2
 293                 mkFunTys [ty1, ty2] ty2,
 294                                         -- f
 295                 ty2,                    -- z
 296                 mkListTy ty1            -- xs
 297                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
 298            let
 299              h_rhs = (Lam x (Case (Var x)
 300                       (AlgAlts
 301                           [(nilDataCon,[],argToExpr (VarArg z)),
 302                            (consDataCon,[a,b],body)]
 303                        NoDefault)))
 304              body = Let (NonRec v (App (Var h) (VarArg b)))
 305                           (App (App (argToExpr (VarArg f))
 306                                                   (VarArg a))
 307                                                     (VarArg v))
 308            in
 309              returnSmpl (Just
 310                      (mkGenApp
 311                          (Lam f (Lam z (Lam xs
 312                           (Let (Rec [(h,h_rhs)])
 313                                  (App (Var h) (VarArg xs))))))
 314                      (ValArg arg_k:rest_args)))
 315    where
 316         doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 317         dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
 318 foldr_fun _ _ = returnSmpl Nothing
 319
 320 isConsFun :: SimplEnv -> CoreArg -> Bool
 321 isConsFun env (VarArg v)
 322   = case lookupUnfolding env v of
 323         GenForm _ _ (Lam (x,_) (Lam (y,_)
 324                         (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         GenForm _ _ (CoTyApp (Var id) _) _
 334           | id == nilDataCon -> True
 335         ConForm id _ _
 336           | id == nilDataCon   -> True
 337         LitForm (NoRepStr s) | _NULL_ s -> True
 338         _ -> False
 339 isNilForm env _ = False
 340
 341 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
 342 getBuildForm env (VarArg v)
 343   = case lookupUnfolding env v of
 344         GenForm False _ _ _ -> Nothing
 345                                         -- not allowed to inline :-(
 346         GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
 347           | bld == buildId -> Just g
 348         GenForm _ _ (App (App (CoTyApp (Var bld) _)
 349                                         (VarArg g)) h) _
 350           | bld == augmentId && isNilForm env h  -> Just g
 351         _ -> Nothing
 352 getBuildForm env _ = Nothing
 353
 354
 355
 356 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
 357 getAugmentForm env (VarArg v)
 358   = case lookupUnfolding env v of
 359         GenForm False _ _ _ -> Nothing
 360                                 -- not allowed to inline :-(
 361         GenForm _ _ (App (App (CoTyApp (Var bld) _)
 362                                                 (VarArg g)) h) _
 363           | bld == augmentId -> Just (g,h)
 364         _ -> Nothing
 365 getAugmentForm env _ = Nothing
 366
 367 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
 368 getStringForm env (LitArg (NoRepStr str)) = Just str
 369 getStringForm env _ = Nothing
 370
 371 {-
 372 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
 373 getAppendForm env (VarArg v) =
 374     case lookupUnfolding env v of
 375         GenForm False _ _ _ -> Nothing  -- not allowed to inline :-(
 376         GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
 377           | fld == foldrId && isConsFun env con -> Just (xs,ys)
 378         _ -> Nothing
 379 getAppendForm env _ = Nothing
 380 -}
 381
 382 --
 383 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
 384 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
 385 --
 386
 387 getListForm
 388         :: SimplEnv
 389         -> CoreArg
 390         -> Maybe ([CoreArg],CoreArg)
 391 getListForm env (VarArg v)
 392   = case lookupUnfolding env v of
 393        ConForm id _ [head,tail]
 394           | id == consDataCon ->
 395                 case getListForm env tail of
 396                    Nothing -> Just ([head],tail)
 397                    Just (lst,new_tail) -> Just (head:lst,new_tail)
 398        _ -> Nothing
 399 getListForm env _ = Nothing
 400
 401 isInterestingArg :: SimplEnv -> CoreArg -> Bool
 402 isInterestingArg env (VarArg v)
 403   = case lookupUnfolding env v of
 404        GenForm False _ _ UnfoldNever -> False
 405        GenForm _ _ exp guide -> True
 406        _ -> False
 407 isInterestingArg env _ = False
 408
 409 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
 410  | do_fb_red && isNilForm env arg_list
 411   =     -- foldl f z [] = z
 412         -- again another short cut, helps with unroling of constant lists
 413     tick Foldl_Nil      `thenSmpl_`
 414     returnSmpl (Just (argToExpr arg_z))
 415
 416   | do_fb_red && arg_list_isBuildForm
 417   =     -- foldl t1 t2 k z (build t3 g) ==>
 418         --                 let c {- INLINE -} = \ b g' a -> g' (f a b)
 419         --                     n {- INLINE -} = \ a -> a
 420         --                 in g t1 c n z
 421         -- this next line *is* the foldr/build rule proper.
 422     tick FoldlBuild     `thenSmpl_`
 423         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
 424         -- n :: t1 -> t1
 425     newIds [
 426         {- pre_c -}     mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
 427         {- pre_n -}     mkFunTys [ty1] ty1,
 428         {- b -}         ty2,
 429         {- g' -}        mkFunTys [ty1] ty1,
 430         {- a -}         ty1,
 431         {- a' -}        ty1,
 432         {- t -}         ty1
 433         ]               `thenSmpl` \ [pre_c,
 434                                       pre_n,
 435                                       b,
 436                                       g',
 437                                       a,
 438                                       a',
 439                                       t] ->
 440
 441     let
 442         c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
 443         c_rhs = Lam b (Lam g' (Lam a
 444                  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
 445                          (App (Var g') (VarArg t)))))
 446         n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
 447         n_rhs = Lam a' (Var a')
 448     in
 449     returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
 450                   (mkGenApp (Var g)
 451                       (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
 452                                 :ValArg arg_z:rest_args)))))
 453
 454   | 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     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     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
 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     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
 488         n_rhs = Lam a' (Var a')
 489         r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
 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 (Just (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  | do_fb_red && arg_list_isListForm
 504  =      -- foldl k z (a:b:c:rest) =
 505         --      (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
 506         -- NB: 'k' is used just one by foldr, but 'f' is used many
 507         -- times inside the list structure. This means that
 508         -- 'f' needs to be inside a lambda, to make sure the simplifier
 509         -- realises this.
 510         --
 511         -- The structure of
 512         --       foldl f (f (f (f z a) b) c) rest
 513         --       f a (f b (f c (foldr f z rest)))
 514         -- in core becomes:
 515         --      let ele_1 = f z a
 516         --          ele_2 = f ele_1 b
 517         --          ele_3 = f ele_2 c
 518         --      in foldl f ele_3 rest
 519         --
 520   tick Foldl_List       `thenSmpl_`
 521   newIds (
 522                 mkFunTys [ty1, ty2] ty1 :
 523                 nOfThem (length the_list) ty1
 524         )                       `thenSmpl` \ (f_id:ele_ids) ->
 525   let
 526         rest_binds = zipWith3Equal "foldl:rest_binds"
 527                          (\ e v e' -> NonRec e (mkRhs v e'))
 528                          ele_ids                                -- :: [Id]
 529                          the_list                               -- :: [CoreArg]
 530                          (init (arg_z:map VarArg ele_ids))      -- :: [CoreArg]
 531         mkRhs v e = App (App (Var f_id) e) v
 532
 533         last_bind = mkGenApp (Var foldlId)
 534                                 [TypeArg ty1,TypeArg ty2,
 535                                  ValArg (VarArg f_id),
 536                                  ValArg (VarArg (last ele_ids)),
 537                                  ValArg the_tl]
 538         core_list = foldr
 539                         Let
 540                         last_bind
 541                         rest_binds
 542   in
 543         returnSmpl (Just (mkGenApp (Lam f_id core_list)
 544                                       (ValArg arg_k:rest_args)))
 545
 546  where
 547    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 548
 549    arg_list_isAugmentForm  = maybeToBool augmentForm
 550    augmentForm             = getAugmentForm env arg_list
 551    (Just (g',h))           = augmentForm
 552
 553    arg_list_isBuildForm = maybeToBool buildForm
 554    buildForm            = getBuildForm env arg_list
 555    (Just g)             = buildForm
 556
 557    arg_list_isListForm      = maybeToBool listForm
 558    listForm                 = getListForm env arg_list
 559    (Just (the_list,the_tl)) = listForm
 560
 561 {-
 562    arg_list_isAppendForm = maybeToBool appendForm
 563    appendForm            = getAppendForm env arg_list
 564    (Just (xs,ys))        = appendForm
 565 -}
 566
 567 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
 568   | doing_inlining && (isInterestingArg env arg_k
 569                        || isConsFun env arg_k)
 570   =   -- foldl k args =
 571       --        (\ f z xs ->
 572       --          letrec
 573       --             h x r = case x of
 574       --                      []    -> r
 575       --                      (a:b) -> h b (f r a)
 576       --          in
 577       --             h xs z) k args
 578       --
 579 --     tick FoldrInline                         `thenSmpl_`
 580      newIds [
 581                 ty2,                    -- a :: t1
 582                 mkListTy ty2,           -- b :: [t1]
 583                 ty1,                    -- v :: t2
 584                 mkListTy ty2,           -- x :: t1
 585                 mkFunTys [mkListTy ty2, ty1] ty1,
 586                                         -- h :: [t2] -> t1 -> t1
 587                 mkFunTys [ty1, ty2] ty1,
 588                                         -- f
 589                 ty1,                    -- z
 590                 mkListTy ty2,           -- xs
 591                 ty1                     -- r
 592                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
 593            let
 594              h_rhs = (Lam x (Lam r (Case (Var x))
 595                       (AlgAlts
 596                           [(nilDataCon,[],argToExpr (VarArg r)),
 597                            (consDataCon,[a,b],body)]
 598                        NoDefault)))
 599              body = Let (NonRec v (App (App (Var f) (VarArg r))
 600                                                               (VarArg a)))
 601                           (App (App (argToExpr (VarArg h))
 602                                                   (VarArg b))
 603                                                     (VarArg v))
 604            in
 605              returnSmpl (Just
 606                      (mkGenApp
 607                          (Lam f (Lam z (Lam xs
 608                           (Let (Rec [(h,h_rhs)])
 609                                  (App (App (Var h) (VarArg xs))
 610                                                          (VarArg z))))))
 611                      (ValArg arg_k:rest_args)))
 612    where
 613         doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 614
 615 foldl_fun env _ = returnSmpl Nothing
 616 \end{code}
 617
 618
 619 \begin{code}
 620 --
 621 --  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
 622 --
 623 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
 624    | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
 625    = tick Str_UnpackCons                `thenSmpl_`
 626      returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
 627                                 [ValArg str,
 628                                  ValArg arg_z]))
 629 unpack_foldr_fun env _ = returnSmpl Nothing
 630
 631 unpack_append_fun env
 632         [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
 633    | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
 634    = tick Str_UnpackNil         `thenSmpl_`
 635      returnSmpl (Just (Lit (NoRepStr str_val)))
 636 unpack_append_fun env _ = returnSmpl Nothing
 637 -}
 638 \end{code}