%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
#include "HsVersions.h"
module MagicUFs (
- MagicUnfoldingFun, -- absolutely abstract
-
- mkMagicUnfoldingFun,
- applyMagicUnfoldingFun,
-
- CoreArg, PlainCoreArg(..), CoreAtom, PlainCoreAtom(..),
- CoreExpr, PlainCoreExpr(..), Id, Maybe, SimplEnv,
- SplitUniqSupply, TickType, UniType,
- SmplM(..), SimplCount
+ MagicUnfoldingFun, -- absolutely abstract
+
+ mkMagicUnfoldingFun,
+ applyMagicUnfoldingFun
) where
-IMPORT_Trace -- ToDo: not sure why this is being used
-
-import AbsPrel ( foldlId, foldrId, buildId, augmentId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId, unpackCStringFoldrId,
- appendId
- )
-import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate )
-import BasicLit ( BasicLit(..) )
-import CmdLineOpts ( SimplifierSwitch(..), switchIsOn, SwitchResult )
-import Id
-import IdInfo
-import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import PlainCore
-import Pretty
-import SimplEnv
-import SimplMonad
-import TaggedCore
-import Util
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop) -- paranoia checking
+
+import Id ( addInlinePragma )
+import CoreSyn
+import SimplEnv ( SimplEnv )
+import SimplMonad ( SYN_IE(SmplM), SimplCount )
+import Type ( mkFunTys )
+import TysWiredIn ( mkListTy )
+import Unique ( Unique{-instances-} )
+import Util ( assoc, zipWith3Equal, nOfThem, panic )
\end{code}
%************************************************************************
\begin{code}
data MagicUnfoldingFun
= MUF ( SimplEnv -- state of play in simplifier...
- -- (note: we can get simplifier switches
- -- from the SimplEnv)
- -> [PlainCoreArg] -- arguments
- -> SmplM (Maybe PlainCoreExpr))
- -- Just result, or Nothing
+ -- (note: we can get simplifier switches
+ -- from the SimplEnv)
+ -> [CoreArg] -- arguments
+ -> Maybe (SmplM CoreExpr))
+ -- Just result, or Nothing
\end{code}
-Give us a string tag, we'll give you back the corresponding MUF.
+Give us a value's @Unique@, we'll give you back the corresponding MUF.
\begin{code}
-mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun
+mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
mkMagicUnfoldingFun tag
- = assoc ("mkMagicUnfoldingFun:" ++ _UNPK_ tag) magic_UFs_table tag
+ = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
+
+magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
\end{code}
Give us an MUF and stuff to apply it to, and we'll give you back the
answer.
\begin{code}
applyMagicUnfoldingFun
- :: MagicUnfoldingFun
- -> SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ :: MagicUnfoldingFun
+ -> SimplEnv
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
applyMagicUnfoldingFun (MUF fun) env args = fun env args
\end{code}
%************************************************************************
\begin{code}
+{- LATER:
+
magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
magic_UFs_table
(SLIT("build"), MUF build_fun),
(SLIT("foldl"), MUF foldl_fun),
(SLIT("foldr"), MUF foldr_fun),
- (SLIT("unpackFoldrPS#"), MUF unpack_foldr_fun),
- (SLIT("unpackAppendPS#"), MUF unpack_append_fun)]
+ (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun),
+ (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
\end{code}
%************************************************************************
-- First build, the way we express our lists.
build_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
-build_fun env [TypeArg ty,ValArg (CoVarAtom e)]
- | switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = mkCoTyApp (CoVar consDataCon) ty
- ourNil = mkCoTyApp (CoVar nilDataCon) ty
- in
- newIds [ ty `mkFunTy` (tyL `mkFunTy` tyL),
- tyL ] `thenSmpl` \ [c,n] ->
- returnSmpl(Just (CoLet (CoNonRec c ourCons)
- (CoLet (CoNonRec n ourNil)
- (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n)))))
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
+build_fun env [TypeArg ty,ValArg (VarArg e)]
+ | switchIsSet env SimplDoInlineFoldrBuild
+ = Just result
+ where
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ ourNil = CoTyApp (Var nilDataCon) ty
+
+ result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
+ returnSmpl(Let (NonRec c ourCons)
+ (Let (NonRec n ourNil)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
+
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-build_fun env _ =
- ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- returnSmpl Nothing
+build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+ Nothing
\end{code}
\begin{code}
augment_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
-augment_fun env [TypeArg ty,ValArg (CoVarAtom e),ValArg nil]
- | switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = mkCoTyApp (CoVar consDataCon) ty
- in
- newId (ty `mkFunTy` (tyL `mkFunTy` tyL)) `thenSmpl` \ c ->
- returnSmpl (Just (CoLet (CoNonRec c ourCons)
- (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) nil)))
+augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
+ | switchIsSet env SimplDoInlineFoldrBuild
+ = Just result
+ where
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
+ returnSmpl (Let (NonRec c ourCons)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-augment_fun env _ =
- ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- returnSmpl Nothing
+
+augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
+ Nothing
\end{code}
Now foldr, the way we consume lists.
\begin{code}
foldr_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
| do_fb_red && isConsFun env arg_k && isNilForm env arg_z
- = -- foldr (:) [] ==> id
+ -- foldr (:) [] ==> id
-- this transformation is *always* benificial
-- cf. foldr (:) [] (build g) == g (:) []
-- with foldr (:) [] (build g) == build g
-- after unfolding build, they are the same thing.
- tick Foldr_Cons_Nil `thenSmpl_`
- newId (mkListTy ty1) `thenSmpl` \ x ->
- returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
+ = Just (tick Foldr_Cons_Nil `thenSmpl_`
+ newId (mkListTy ty1) `thenSmpl` \ x ->
+ returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
| do_fb_red && isNilForm env arg_list
- = -- foldr f z [] = z
+ -- foldr f z [] = z
-- again another short cut, helps with unroling of constant lists
- tick Foldr_Nil `thenSmpl_`
- returnSmpl (Just (atomToExpr arg_z))
+ = Just (tick Foldr_Nil `thenSmpl_`
+ returnSmpl (argToExpr arg_z)
+ )
- | do_fb_red && arg_list_isBuildForm
- = -- foldr k z (build g) ==> g k z
+ | do_fb_red && arg_list_isBuildForm
+ -- foldr k z (build g) ==> g k z
-- this next line *is* the foldr/build rule proper.
- tick FoldrBuild `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
+ = Just (tick FoldrBuild `thenSmpl_`
+ returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
+ )
- | do_fb_red && arg_list_isAugmentForm
- = -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
+ | do_fb_red && arg_list_isAugmentForm
+ -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
-- this next line *is* the foldr/augment rule proper.
- tick FoldrAugment `thenSmpl_`
- newId ty2 `thenSmpl` \ v ->
- returnSmpl (Just
- (CoLet (CoNonRec v (applyToArgs (CoVar foldrId)
+ = Just (tick FoldrAugment `thenSmpl_`
+ newId ty2 `thenSmpl` \ v ->
+ returnSmpl (
+ Let (NonRec v (mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg arg_k,
ValArg arg_z,
ValArg h]))
- (applyToArgs (CoVar g') (TypeArg ty2:ValArg arg_k:ValArg (CoVarAtom v):rest_args))))
+ (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
+ )
| do_fb_red && arg_list_isListForm
- = -- foldr k z (a:b:c:rest) =
+ -- foldr k z (a:b:c:rest) =
-- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- 'f' needs to be inside a lambda, to make sure the simplifier
-- realises this.
- --
- -- The structure of
+ --
+ -- The structure of
-- f a (f b (f c (foldr f z rest)))
-- in core becomes:
-- let ele_1 = foldr f z rest
-- ele_3 = f b ele_2
-- in f a ele_3
--
- tick Foldr_List `thenSmpl_`
- newIds (
- ty1 `mkFunTy` (ty2 `mkFunTy` ty2) :
- take (length the_list) (repeat ty2)
- ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
- let
- fst_bind = CoNonRec
- ele_id1
- (applyToArgs (CoVar foldrId)
+ = Just (tick Foldr_List `thenSmpl_`
+ newIds (
+ mkFunTys [ty1, ty2] ty2 :
+ nOfThem (length the_list) ty2
+ ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
+ let
+ fst_bind = NonRec
+ ele_id1
+ (mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
- ValArg (CoVarAtom f_id),
+ ValArg (VarArg f_id),
ValArg arg_z,
ValArg the_tl])
- --ToDo: look for a zipWith that checks for the same length of a 3 lists
- rest_binds = zipWith3
- (\ e v e' -> CoNonRec e (mkRhs v e'))
+ rest_binds = zipWith3Equal "Foldr:rest_binds"
+ (\ e v e' -> NonRec e (mkRhs v e'))
ele_ids
(reverse (tail the_list))
(init (ele_id1:ele_ids))
- mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e)
- core_list = foldr
- CoLet
+ mkRhs v e = App (App (Var f_id) v) (VarArg e)
+ core_list = foldr
+ Let
(mkRhs (head the_list) (last (ele_id1:ele_ids)))
(fst_bind:rest_binds)
- in
- returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
- (ValArg arg_k:rest_args)))
+ in
+ returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
+ )
- --
+ --
| do_fb_red && arg_list_isStringForm -- ok, its a string!
- -- foldr f z "foo" => unpackFoldrPS# f z "foo"#
- = tick Str_FoldrStr `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar unpackCStringFoldrId)
+ -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
+ = Just (tick Str_FoldrStr `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringFoldrId)
(TypeArg ty2:
- ValArg (CoLitAtom (MachStr str_val)):
+ ValArg (LitArg (MachStr str_val)):
ValArg arg_k:
ValArg arg_z:
- rest_args)))
+ rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
| doing_inlining && isConsFun env arg_k && not dont_fold_back_append
- = -- foldr (:) z xs = xs ++ z
- tick Foldr_Cons `thenSmpl_`
- newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
- returnSmpl (Just (applyToArgs
- (CoLam [z,x] (applyToArgs
- (CoVar appendId) [
- TypeArg ty1,
- ValArg (CoVarAtom x),
- ValArg (CoVarAtom z)]))
- rest_args))
- | doing_inlining && (isInterestingArg env arg_k
+ -- foldr (:) z xs = xs ++ z
+ = Just (tick Foldr_Cons `thenSmpl_`
+ newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
+ returnSmpl (mkGenApp
+ (Lam z (Lam x (mkGenApp
+ (Var appendId) [
+ TypeArg ty1,
+ ValArg (VarArg x),
+ ValArg (VarArg z)]))
+ rest_args))
+ )
+
+ | doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldr k args =
+ -- foldr k args =
-- (\ f z xs ->
- -- letrec
+ -- letrec
-- h x = case x of
-- [] -> z
-- (a:b) -> f a (h b)
-- h xs) k args
--
-- tick FoldrInline `thenSmpl_`
- newIds [
- ty1, -- a :: t1
- mkListTy ty1, -- b :: [t1]
- ty2, -- v :: t2
- mkListTy ty1, -- x :: t1
- mkListTy ty1 `mkFunTy` ty2,
- -- h :: [t1] -> t2
- ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
- -- f
- ty2, -- z
- mkListTy ty1 -- xs
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
- let
- h_rhs = (CoLam [x] (CoCase (CoVar x)
- (CoAlgAlts
- [(nilDataCon,[],atomToExpr (CoVarAtom z)),
- (consDataCon,[a,b],body)]
- CoNoDefault)))
- body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
- (CoApp (CoApp (atomToExpr (CoVarAtom f))
- (CoVarAtom a))
- (CoVarAtom v))
- in
- returnSmpl (Just
- (applyToArgs
- (CoLam [f,z,xs]
- (CoLet (CoRec [(h,h_rhs)])
- (CoApp (CoVar h) (CoVarAtom xs))))
- (ValArg arg_k:rest_args)))
+ = Just (newIds [
+ ty1, -- a :: t1
+ mkListTy ty1, -- b :: [t1]
+ ty2, -- v :: t2
+ mkListTy ty1, -- x :: t1
+ mkFunTys [mkListTy ty1] ty2,
+ -- h :: [t1] -> t2
+ mkFunTys [ty1, ty2] ty2,
+ -- f
+ ty2, -- z
+ mkListTy ty1 -- xs
+ ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
+ let
+ h_rhs = (Lam x (Case (Var x)
+ (AlgAlts
+ [(nilDataCon,[],argToExpr (VarArg z)),
+ (consDataCon,[a,b],body)]
+ NoDefault)))
+ body = Let (NonRec v (App (Var h) (VarArg b)))
+ (App (App (argToExpr (VarArg f))
+ (VarArg a))
+ (VarArg v))
+ in
+ returnSmpl (
+ mkGenApp
+ (Lam f (Lam z (Lam xs
+ (Let (Rec [(h,h_rhs)])
+ (App (Var h) (VarArg xs))))))
+ (ValArg arg_k:rest_args))
+ )
where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
- dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
-foldr_fun _ _ = returnSmpl Nothing
-
-isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
-isConsFun env (CoVarAtom v) =
- case lookupUnfolding env v of
- GeneralForm _ _ (CoLam [(x,_),(y,_)]
- (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _
- | con == consDataCon && x==x' && y==y'
- -> ASSERT ( length tys == 1 ) True
- _ -> False
+ doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+ dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
+
+foldr_fun _ _ = Nothing
+
+isConsFun :: SimplEnv -> CoreArg -> Bool
+isConsFun env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
+ | con == consDataCon && x==x' && y==y'
+ -> ASSERT ( length tys == 1 ) True
+ _ -> False
isConsFun env _ = False
-isNilForm :: SimplEnv -> PlainCoreAtom -> Bool
-isNilForm env (CoVarAtom v) =
- case lookupUnfolding env v of
- GeneralForm _ _ (CoTyApp (CoVar id) _) _
- | id == nilDataCon -> True
- ConstructorForm id _ _
- | id == nilDataCon -> True
- LiteralForm (NoRepStr s) | _NULL_ s -> True
- _ -> False
+isNilForm :: SimplEnv -> CoreArg -> Bool
+isNilForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
+ SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
+ _ -> False
isNilForm env _ = False
-getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
-getBuildForm env (CoVarAtom v) =
- case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing
+getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
+getBuildForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding False _ _ _ -> Nothing
-- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
- | bld == buildId -> Just g
- GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
- (CoVarAtom g)) h) _
- | bld == augmentId && isNilForm env h -> Just g
- _ -> Nothing
+ SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+ | bld == buildId -> Just g
+ SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
+ (VarArg g)) h) _
+ | bld == augmentId && isNilForm env h -> Just g
+ _ -> Nothing
getBuildForm env _ = Nothing
-getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom)
-getAugmentForm env (CoVarAtom v) =
- case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing
+getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
+getAugmentForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding False _ _ _ -> Nothing
-- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
- (CoVarAtom g)) h) _
- | bld == augmentId -> Just (g,h)
- _ -> Nothing
+ SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
+ (VarArg g)) h) _
+ | bld == augmentId -> Just (g,h)
+ _ -> Nothing
getAugmentForm env _ = Nothing
-getStringForm :: SimplEnv -> PlainCoreAtom -> Maybe FAST_STRING
-getStringForm env (CoLitAtom (NoRepStr str)) = Just str
+getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
+getStringForm env (LitArg (NoRepStr str)) = Just str
getStringForm env _ = Nothing
{-
-getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
-getAppendForm env (CoVarAtom v) =
+getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
+getAppendForm env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _
- | fld == foldrId && isConsFun env con -> Just (xs,ys)
- _ -> Nothing
+ SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
+ SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+ | fld == foldrId && isConsFun env con -> Just (xs,ys)
+ _ -> Nothing
getAppendForm env _ = Nothing
-}
--
getListForm
- :: SimplEnv
- -> PlainCoreAtom
- -> Maybe ([PlainCoreAtom],PlainCoreAtom)
-getListForm env (CoVarAtom v) =
- case lookupUnfolding env v of
- ConstructorForm id _ [head,tail]
- | id == consDataCon ->
+ :: SimplEnv
+ -> CoreArg
+ -> Maybe ([CoreArg],CoreArg)
+getListForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
+ | id == consDataCon ->
case getListForm env tail of
Nothing -> Just ([head],tail)
Just (lst,new_tail) -> Just (head:lst,new_tail)
_ -> Nothing
getListForm env _ = Nothing
-isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool
-isInterestingArg env (CoVarAtom v) =
- case lookupUnfolding env v of
- GeneralForm False _ _ UnfoldNever -> False
- GeneralForm _ _ exp guide -> True
+isInterestingArg :: SimplEnv -> CoreArg -> Bool
+isInterestingArg env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding False _ _ UnfoldNever -> False
+ SimpleUnfolding _ exp guide -> True
_ -> False
isInterestingArg env _ = False
foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
| do_fb_red && isNilForm env arg_list
- = -- foldl f z [] = z
+ -- foldl f z [] = z
-- again another short cut, helps with unroling of constant lists
- tick Foldl_Nil `thenSmpl_`
- returnSmpl (Just (atomToExpr arg_z))
+ = Just (tick Foldl_Nil `thenSmpl_`
+ returnSmpl (argToExpr arg_z)
+ )
- | do_fb_red && arg_list_isBuildForm
- = -- foldl t1 t2 k z (build t3 g) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
+ | do_fb_red && arg_list_isBuildForm
+ -- foldl t1 t2 k z (build t3 g) ==>
+ -- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- in g t1 c n z
-- this next line *is* the foldr/build rule proper.
- tick FoldlBuild `thenSmpl_`
+ = Just(tick FoldlBuild `thenSmpl_`
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
- newIds [
- {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
- {- pre_n -} ty1 `mkFunTy` ty1,
- {- b -} ty2,
- {- g' -} ty1 `mkFunTy` ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
+ newIds [
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
+ {- b -} ty2,
+ {- g' -} mkFunTys [ty1] ty1,
+ {- a -} ty1,
+ {- a' -} ty1,
+ {- t -} ty1
+ ] `thenSmpl` \ [pre_c,
pre_n,
b,
g',
a',
t] ->
- let
- c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = CoLam [b,g',a]
- (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
- (CoApp (CoVar g') (CoVarAtom t)))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = CoLam [a'] (CoVar a')
- in
- returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs)
- (applyToArgs (CoVar g)
- (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n)
- :ValArg arg_z:rest_args)))))
-
- | do_fb_red && arg_list_isAugmentForm
- = -- foldl t1 t2 k z (augment t3 g h) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
+ let
+ c = addInlinePragma pre_c
+ c_rhs = Lam b (Lam g' (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ (App (Var g') (VarArg t)))))
+ n = addInlinePragma pre_n
+ n_rhs = Lam a' (Var a')
+ in
+ returnSmpl (Let (NonRec c c_rhs) $
+ Let (NonRec n n_rhs) $
+ mkGenApp (Var g)
+ (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
+ :ValArg arg_z:rest_args))
+ )
+
+ | do_fb_red && arg_list_isAugmentForm
+ -- foldl t1 t2 k z (augment t3 g h) ==>
+ -- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
-- in g t1 c r z
-- this next line *is* the foldr/build rule proper.
- tick FoldlAugment `thenSmpl_`
+ = Just (tick FoldlAugment `thenSmpl_`
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
- newIds [
- {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
- {- pre_n -} ty1 `mkFunTy` ty1,
- {- pre_r -} ty1 `mkFunTy` ty1,
- {- b -} ty2,
- {- g_ -} ty1 `mkFunTy` ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
+ newIds [
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
+ {- pre_r -} mkFunTys [ty1] ty1,
+ {- b -} ty2,
+ {- g_ -} mkFunTys [ty1] ty1,
+ {- a -} ty1,
+ {- a' -} ty1,
+ {- t -} ty1
+ ] `thenSmpl` \ [pre_c,
pre_n,
pre_r,
b,
a',
t] ->
- let
- c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = CoLam [b,g_,a]
- (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
- (CoApp (CoVar g_) (CoVarAtom t)))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = CoLam [a'] (CoVar a')
- r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
- r_rhs = applyToArgs (CoVar foldrId)
- [TypeArg ty2,TypeArg (ty1 `mkFunTy` ty1),
- ValArg (CoVarAtom c),
- ValArg (CoVarAtom n),
+ let
+ c = addInlinePragma pre_c
+ c_rhs = Lam b (Lam g_ (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ (App (Var g_) (VarArg t)))))
+ n = addInlinePragma pre_n
+ n_rhs = Lam a' (Var a')
+ r = addInlinePragma pre_r
+ r_rhs = mkGenApp (Var foldrId)
+ [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
+ ValArg (VarArg c),
+ ValArg (VarArg n),
ValArg h]
- in
- returnSmpl (Just (CoLet (CoNonRec c c_rhs)
- (CoLet (CoNonRec n n_rhs)
- (CoLet (CoNonRec r r_rhs)
- (applyToArgs (CoVar g')
- (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom r)
- :ValArg arg_z:rest_args))))))
+ in
+ returnSmpl (Let (NonRec c c_rhs) $
+ Let (NonRec n n_rhs) $
+ Let (NonRec r r_rhs) $
+ mkGenApp (Var g')
+ (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
+ :ValArg arg_z:rest_args))
+ )
| do_fb_red && arg_list_isListForm
- = -- foldl k z (a:b:c:rest) =
+ -- foldl k z (a:b:c:rest) =
-- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- 'f' needs to be inside a lambda, to make sure the simplifier
-- realises this.
- --
- -- The structure of
+ --
+ -- The structure of
-- foldl f (f (f (f z a) b) c) rest
-- f a (f b (f c (foldr f z rest)))
-- in core becomes:
-- ele_3 = f ele_2 c
-- in foldl f ele_3 rest
--
- tick Foldl_List `thenSmpl_`
- newIds (
- ty1 `mkFunTy` (ty2 `mkFunTy` ty1) :
- take (length the_list) (repeat ty1)
- ) `thenSmpl` \ (f_id:ele_ids) ->
- let
- --ToDo: look for a zipWith that checks for the same length of a 3 lists
- rest_binds = zipWith3
- (\ e v e' -> CoNonRec e (mkRhs v e'))
+ = Just (tick Foldl_List `thenSmpl_`
+ newIds (
+ mkFunTys [ty1, ty2] ty1 :
+ nOfThem (length the_list) ty1
+ ) `thenSmpl` \ (f_id:ele_ids) ->
+ let
+ rest_binds = zipWith3Equal "foldl:rest_binds"
+ (\ e v e' -> NonRec e (mkRhs v e'))
ele_ids -- :: [Id]
- the_list -- :: [PlainCoreAtom]
- (init (arg_z:map CoVarAtom ele_ids)) -- :: [PlainCoreAtom]
- mkRhs v e = CoApp (CoApp (CoVar f_id) e) v
+ the_list -- :: [CoreArg]
+ (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
+ mkRhs v e = App (App (Var f_id) e) v
- last_bind = applyToArgs (CoVar foldlId)
+ last_bind = mkGenApp (Var foldlId)
[TypeArg ty1,TypeArg ty2,
- ValArg (CoVarAtom f_id),
- ValArg (CoVarAtom (last ele_ids)),
+ ValArg (VarArg f_id),
+ ValArg (VarArg (last ele_ids)),
ValArg the_tl]
- core_list = foldr
- CoLet
+ core_list = foldr
+ Let
last_bind
rest_binds
- in
- returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
- (ValArg arg_k:rest_args)))
+ in
+ returnSmpl (mkGenApp (Lam f_id core_list)
+ (ValArg arg_k:rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
-}
foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
- | doing_inlining && (isInterestingArg env arg_k
+ | doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldl k args =
+ -- foldl k args =
-- (\ f z xs ->
- -- letrec
+ -- letrec
-- h x r = case x of
-- [] -> r
-- (a:b) -> h b (f r a)
-- in
-- h xs z) k args
--
+ = Just (
-- tick FoldrInline `thenSmpl_`
newIds [
- ty2, -- a :: t1
- mkListTy ty2, -- b :: [t1]
- ty1, -- v :: t2
- mkListTy ty2, -- x :: t1
- mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1),
- -- h :: [t2] -> t1 -> t1
- ty1 `mkFunTy` (ty2 `mkFunTy` ty1),
- -- f
- ty1, -- z
- mkListTy ty2, -- xs
+ ty2, -- a :: t1
+ mkListTy ty2, -- b :: [t1]
+ ty1, -- v :: t2
+ mkListTy ty2, -- x :: t1
+ mkFunTys [mkListTy ty2, ty1] ty1,
+ -- h :: [t2] -> t1 -> t1
+ mkFunTys [ty1, ty2] ty1,
+ -- f
+ ty1, -- z
+ mkListTy ty2, -- xs
ty1 -- r
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
- let
- h_rhs = (CoLam [x,r] (CoCase (CoVar x)
- (CoAlgAlts
- [(nilDataCon,[],atomToExpr (CoVarAtom r)),
- (consDataCon,[a,b],body)]
- CoNoDefault)))
- body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r))
- (CoVarAtom a)))
- (CoApp (CoApp (atomToExpr (CoVarAtom h))
- (CoVarAtom b))
- (CoVarAtom v))
- in
- returnSmpl (Just
- (applyToArgs
- (CoLam [f,z,xs]
- (CoLet (CoRec [(h,h_rhs)])
- (CoApp (CoApp (CoVar h) (CoVarAtom xs))
- (CoVarAtom z))))
- (ValArg arg_k:rest_args)))
+ ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
+ let
+ h_rhs = (Lam x (Lam r (Case (Var x))
+ (AlgAlts
+ [(nilDataCon,[],argToExpr (VarArg r)),
+ (consDataCon,[a,b],body)]
+ NoDefault)))
+ body = Let (NonRec v (App (App (Var f) (VarArg r))
+ (VarArg a)))
+ (App (App (argToExpr (VarArg h))
+ (VarArg b))
+ (VarArg v))
+ in
+ returnSmpl (
+ (mkGenApp
+ (Lam f (Lam z (Lam xs
+ (Let (Rec [(h,h_rhs)])
+ (App (App (Var h) (VarArg xs))
+ (VarArg z))))))
+ (ValArg arg_k:rest_args))
+ )
where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+ doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-foldl_fun env _ = returnSmpl Nothing
+foldl_fun env _ = Nothing
\end{code}
\begin{code}
--
--- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
+-- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
--
unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
- = tick Str_UnpackCons `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar unpackCStringAppendId)
+ = Just (tick Str_UnpackCons `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringAppendId)
[ValArg str,
- ValArg arg_z]))
-unpack_foldr_fun env _ = returnSmpl Nothing
+ ValArg arg_z])
+ )
+unpack_foldr_fun env _ = Nothing
-unpack_append_fun env
- [ValArg (CoLitAtom (MachStr str_val)),ValArg arg_z]
+unpack_append_fun env
+ [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
- = tick Str_UnpackNil `thenSmpl_`
- returnSmpl (Just (CoLit (NoRepStr str_val)))
-unpack_append_fun env _ = returnSmpl Nothing
+ = Just (tick Str_UnpackNil `thenSmpl_`
+ returnSmpl (Lit (NoRepStr str_val))
+ )
+unpack_append_fun env _ = Nothing
+-}
\end{code}