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