ghc/compiler/simplCore/MagicUFs.lhs

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