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