ghc/compiler/simplCore/MagicUFs.lhs

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