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       ( 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         -> 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,_) (Con con tys [VarArg x',VarArg y']))) _
 324           | con == consDataCon && x==x' && y==y'
 325           -> ASSERT ( length tys == 1 ) True
 326         _ -> False
 327 isConsFun env _ = False
 328
 329 isNilForm :: SimplEnv -> CoreArg -> Bool
 330 isNilForm env (VarArg v)
 331   = case lookupUnfolding env v of
 332         GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
 333         GenForm _ (Lit (NoRepStr s))   _ | _NULL_ s           -> True
 334         _                                                     -> False
 335 isNilForm env _ = False
 336
 337 getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
 338 getBuildForm env (VarArg v)
 339   = case lookupUnfolding env v of
 340         GenForm False _ _ _ -> Nothing
 341                                         -- not allowed to inline :-(
 342         GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
 343           | bld == buildId -> Just g
 344         GenForm _ (App (App (CoTyApp (Var bld) _)
 345                                         (VarArg g)) h) _
 346           | bld == augmentId && isNilForm env h  -> Just g
 347         _ -> Nothing
 348 getBuildForm env _ = Nothing
 349
 350
 351
 352 getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
 353 getAugmentForm env (VarArg v)
 354   = case lookupUnfolding env v of
 355         GenForm False _ _ _ -> Nothing
 356                                 -- not allowed to inline :-(
 357         GenForm _ (App (App (CoTyApp (Var bld) _)
 358                                                 (VarArg g)) h) _
 359           | bld == augmentId -> Just (g,h)
 360         _ -> Nothing
 361 getAugmentForm env _ = Nothing
 362
 363 getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
 364 getStringForm env (LitArg (NoRepStr str)) = Just str
 365 getStringForm env _ = Nothing
 366
 367 {-
 368 getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
 369 getAppendForm env (VarArg v) =
 370     case lookupUnfolding env v of
 371         GenForm False _ _ _ -> Nothing  -- not allowed to inline :-(
 372         GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
 373           | fld == foldrId && isConsFun env con -> Just (xs,ys)
 374         _ -> Nothing
 375 getAppendForm env _ = Nothing
 376 -}
 377
 378 --
 379 -- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
 380 -- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
 381 --
 382
 383 getListForm
 384         :: SimplEnv
 385         -> CoreArg
 386         -> Maybe ([CoreArg],CoreArg)
 387 getListForm env (VarArg v)
 388   = case lookupUnfolding env v of
 389        GenForm _ (Con id [ty_arg,head,tail]) _
 390           | id == consDataCon ->
 391                 case getListForm env tail of
 392                    Nothing -> Just ([head],tail)
 393                    Just (lst,new_tail) -> Just (head:lst,new_tail)
 394        _ -> Nothing
 395 getListForm env _ = Nothing
 396
 397 isInterestingArg :: SimplEnv -> CoreArg -> Bool
 398 isInterestingArg env (VarArg v)
 399   = case lookupUnfolding env v of
 400        GenForm False _ _ UnfoldNever -> False
 401        GenForm _ exp guide -> True
 402        _ -> False
 403 isInterestingArg env _ = False
 404
 405 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
 406  | do_fb_red && isNilForm env arg_list
 407   =     -- foldl f z [] = z
 408         -- again another short cut, helps with unroling of constant lists
 409     tick Foldl_Nil      `thenSmpl_`
 410     returnSmpl (Just (argToExpr arg_z))
 411
 412   | do_fb_red && arg_list_isBuildForm
 413   =     -- foldl t1 t2 k z (build t3 g) ==>
 414         --                 let c {- INLINE -} = \ b g' a -> g' (f a b)
 415         --                     n {- INLINE -} = \ a -> a
 416         --                 in g t1 c n z
 417         -- this next line *is* the foldr/build rule proper.
 418     tick FoldlBuild     `thenSmpl_`
 419         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
 420         -- n :: t1 -> t1
 421     newIds [
 422         {- pre_c -}     mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
 423         {- pre_n -}     mkFunTys [ty1] ty1,
 424         {- b -}         ty2,
 425         {- g' -}        mkFunTys [ty1] ty1,
 426         {- a -}         ty1,
 427         {- a' -}        ty1,
 428         {- t -}         ty1
 429         ]               `thenSmpl` \ [pre_c,
 430                                       pre_n,
 431                                       b,
 432                                       g',
 433                                       a,
 434                                       a',
 435                                       t] ->
 436
 437     let
 438         c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
 439         c_rhs = Lam b (Lam g' (Lam a
 440                  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
 441                          (App (Var g') (VarArg t)))))
 442         n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
 443         n_rhs = Lam a' (Var a')
 444     in
 445     returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
 446                   (mkGenApp (Var g)
 447                       (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
 448                                 :ValArg arg_z:rest_args)))))
 449
 450   | do_fb_red && arg_list_isAugmentForm
 451   =     -- foldl t1 t2 k z (augment t3 g h) ==>
 452         --                 let c {- INLINE -} = \ b g' a -> g' (f a b)
 453         --                     n {- INLINE -} = \ a -> a
 454         --                     r {- INLINE -} = foldr t2 (t1 -> t1) c n h
 455         --                 in g t1 c r z
 456         -- this next line *is* the foldr/build rule proper.
 457     tick FoldlAugment   `thenSmpl_`
 458         -- c :: t2 -> (t1 -> t1) -> t1 -> t1
 459         -- n :: t1 -> t1
 460     newIds [
 461         {- pre_c -}     mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
 462         {- pre_n -}     mkFunTys [ty1] ty1,
 463         {- pre_r -}     mkFunTys [ty1] ty1,
 464         {- b -}         ty2,
 465         {- g_ -}        mkFunTys [ty1] ty1,
 466         {- a -}         ty1,
 467         {- a' -}        ty1,
 468         {- t -}         ty1
 469         ]               `thenSmpl` \ [pre_c,
 470                                       pre_n,
 471                                       pre_r,
 472                                       b,
 473                                       g_,
 474                                       a,
 475                                       a',
 476                                       t] ->
 477
 478     let
 479         c     = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
 480         c_rhs = Lam b (Lam g_ (Lam a
 481                  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
 482                          (App (Var g_) (VarArg t)))))
 483         n     = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
 484         n_rhs = Lam a' (Var a')
 485         r     = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
 486         r_rhs = mkGenApp (Var foldrId)
 487                                         [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
 488                                          ValArg (VarArg c),
 489                                          ValArg (VarArg n),
 490                                          ValArg h]
 491     in
 492     returnSmpl (Just (Let (NonRec c c_rhs)
 493                      (Let (NonRec n n_rhs)
 494                      (Let (NonRec r r_rhs)
 495                   (mkGenApp (Var g')
 496                       (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
 497                                 :ValArg arg_z:rest_args))))))
 498
 499  | do_fb_red && arg_list_isListForm
 500  =      -- foldl k z (a:b:c:rest) =
 501         --      (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
 502         -- NB: 'k' is used just one by foldr, but 'f' is used many
 503         -- times inside the list structure. This means that
 504         -- 'f' needs to be inside a lambda, to make sure the simplifier
 505         -- realises this.
 506         --
 507         -- The structure of
 508         --       foldl f (f (f (f z a) b) c) rest
 509         --       f a (f b (f c (foldr f z rest)))
 510         -- in core becomes:
 511         --      let ele_1 = f z a
 512         --          ele_2 = f ele_1 b
 513         --          ele_3 = f ele_2 c
 514         --      in foldl f ele_3 rest
 515         --
 516   tick Foldl_List       `thenSmpl_`
 517   newIds (
 518                 mkFunTys [ty1, ty2] ty1 :
 519                 nOfThem (length the_list) ty1
 520         )                       `thenSmpl` \ (f_id:ele_ids) ->
 521   let
 522         rest_binds = zipWith3Equal "foldl:rest_binds"
 523                          (\ e v e' -> NonRec e (mkRhs v e'))
 524                          ele_ids                                -- :: [Id]
 525                          the_list                               -- :: [CoreArg]
 526                          (init (arg_z:map VarArg ele_ids))      -- :: [CoreArg]
 527         mkRhs v e = App (App (Var f_id) e) v
 528
 529         last_bind = mkGenApp (Var foldlId)
 530                                 [TypeArg ty1,TypeArg ty2,
 531                                  ValArg (VarArg f_id),
 532                                  ValArg (VarArg (last ele_ids)),
 533                                  ValArg the_tl]
 534         core_list = foldr
 535                         Let
 536                         last_bind
 537                         rest_binds
 538   in
 539         returnSmpl (Just (mkGenApp (Lam f_id core_list)
 540                                       (ValArg arg_k:rest_args)))
 541
 542  where
 543    do_fb_red            = switchIsSet env SimplDoFoldrBuild
 544
 545    arg_list_isAugmentForm  = maybeToBool augmentForm
 546    augmentForm             = getAugmentForm env arg_list
 547    (Just (g',h))           = augmentForm
 548
 549    arg_list_isBuildForm = maybeToBool buildForm
 550    buildForm            = getBuildForm env arg_list
 551    (Just g)             = buildForm
 552
 553    arg_list_isListForm      = maybeToBool listForm
 554    listForm                 = getListForm env arg_list
 555    (Just (the_list,the_tl)) = listForm
 556
 557 {-
 558    arg_list_isAppendForm = maybeToBool appendForm
 559    appendForm            = getAppendForm env arg_list
 560    (Just (xs,ys))        = appendForm
 561 -}
 562
 563 foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
 564   | doing_inlining && (isInterestingArg env arg_k
 565                        || isConsFun env arg_k)
 566   =   -- foldl k args =
 567       --        (\ f z xs ->
 568       --          letrec
 569       --             h x r = case x of
 570       --                      []    -> r
 571       --                      (a:b) -> h b (f r a)
 572       --          in
 573       --             h xs z) k args
 574       --
 575 --     tick FoldrInline                         `thenSmpl_`
 576      newIds [
 577                 ty2,                    -- a :: t1
 578                 mkListTy ty2,           -- b :: [t1]
 579                 ty1,                    -- v :: t2
 580                 mkListTy ty2,           -- x :: t1
 581                 mkFunTys [mkListTy ty2, ty1] ty1,
 582                                         -- h :: [t2] -> t1 -> t1
 583                 mkFunTys [ty1, ty2] ty1,
 584                                         -- f
 585                 ty1,                    -- z
 586                 mkListTy ty2,           -- xs
 587                 ty1                     -- r
 588                         ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
 589            let
 590              h_rhs = (Lam x (Lam r (Case (Var x))
 591                       (AlgAlts
 592                           [(nilDataCon,[],argToExpr (VarArg r)),
 593                            (consDataCon,[a,b],body)]
 594                        NoDefault)))
 595              body = Let (NonRec v (App (App (Var f) (VarArg r))
 596                                                               (VarArg a)))
 597                           (App (App (argToExpr (VarArg h))
 598                                                   (VarArg b))
 599                                                     (VarArg v))
 600            in
 601              returnSmpl (Just
 602                      (mkGenApp
 603                          (Lam f (Lam z (Lam xs
 604                           (Let (Rec [(h,h_rhs)])
 605                                  (App (App (Var h) (VarArg xs))
 606                                                          (VarArg z))))))
 607                      (ValArg arg_k:rest_args)))
 608    where
 609         doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
 610
 611 foldl_fun env _ = returnSmpl Nothing
 612 \end{code}
 613
 614
 615 \begin{code}
 616 --
 617 --  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
 618 --
 619 unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
 620    | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
 621    = tick Str_UnpackCons                `thenSmpl_`
 622      returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
 623                                 [ValArg str,
 624                                  ValArg arg_z]))
 625 unpack_foldr_fun env _ = returnSmpl Nothing
 626
 627 unpack_append_fun env
 628         [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
 629    | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
 630    = tick Str_UnpackNil         `thenSmpl_`
 631      returnSmpl (Just (Lit (NoRepStr str_val)))
 632 unpack_append_fun env _ = returnSmpl Nothing
 633 -}
 634 \end{code}