%
-% (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,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId
- )
-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("augment"), MUF augment_fun),
+ (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)]
\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}
--- Now foldr, the way we consume lists.
+\begin{code}
+augment_fun :: SimplEnv
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
+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))
+ Nothing
+\end{code}
+
+Now foldr, the way we consume lists.
+
+\begin{code}
foldr_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
-{-
-foldr_fun env _
- | trace "HEHJDHF!" False = error "NEVER"
--}
+ -> [CoreArg]
+ -> Maybe (SmplM CoreExpr)
+
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
- | isConsFun env arg_k && isNilForm env arg_z
- = -- foldr (:) [] ==> id
+ | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
+ -- 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 FoldrConsNil `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)))
-
- | do_fb_red && arg_list_isAppendForm
- = -- foldr k z (foldr (:) ys xs) <args> ==> foldr k (foldr k z ys) xs <args>
- -- this unfolds foldr one into foldr
- tick FoldrFoldr `thenSmpl_`
- newId ty2 `thenSmpl` \ other_foldr ->
- let
- inner_foldr = applyToArgs (CoVar foldrId)
- [TypeArg ty1,TypeArg ty2,
- ValArg arg_k,ValArg arg_z,ValArg ys]
- outer_foldr = applyToArgs (CoVar foldrId)
- ([TypeArg ty1,TypeArg ty2,
- ValArg arg_k,ValArg (CoVarAtom other_foldr),ValArg xs]
- ++ rest_args)
- in returnSmpl (Just (CoLet (CoNonRec other_foldr inner_foldr) outer_foldr))
+ = 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
+ -- this next line *is* the foldr/augment rule proper.
+ = 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]))
+ (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"#
+ = Just (tick Str_FoldrStr `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringFoldrId)
+ (TypeArg ty2:
+ ValArg (LitArg (MachStr str_val)):
+ ValArg arg_k:
+ ValArg arg_z:
+ rest_args))
+ )
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
+ arg_list_isStringForm = maybeToBool stringForm
+ stringForm = getStringForm env arg_list
+ (Just str_val) = stringForm
+
arg_list_isBuildForm = maybeToBool buildForm
buildForm = getBuildForm env arg_list
(Just g) = buildForm
+ arg_list_isAugmentForm = maybeToBool augmentForm
+ augmentForm = getAugmentForm env arg_list
+ (Just (g',h)) = augmentForm
+
arg_list_isListForm = maybeToBool listForm
listForm = getListForm env arg_list
(Just (the_list,the_tl)) = listForm
-
+{-
arg_list_isAppendForm = maybeToBool appendForm
appendForm = getAppendForm env arg_list
(Just (xs,ys)) = appendForm
+-}
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
-{- OLD:
- | doing_inlining && isConsFun env arg_k
- = -- foldr (:) z xs = xs ++ z
- tick FoldrCons `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
+ | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
+ -- 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)
-- in
-- 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)))
+-- tick FoldrInline `thenSmpl_`
+ = 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
-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 -- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
- | bld == buildId -> Just g
- _ -> Nothing
+getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
+getBuildForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding False _ _ _ -> Nothing
+ -- not allowed to inline :-(
+ 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
-getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
-getAppendForm env (CoVarAtom v) =
+
+
+getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
+getAugmentForm env (VarArg v)
+ = case lookupUnfolding env v of
+ SimpleUnfolding False _ _ _ -> Nothing
+ -- not allowed to inline :-(
+ SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
+ (VarArg g)) h) _
+ | bld == augmentId -> Just (g,h)
+ _ -> Nothing
+getAugmentForm env _ = Nothing
+
+getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
+getStringForm env (LitArg (NoRepStr str)) = Just str
+getStringForm env _ = Nothing
+
+{-
+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
+-}
--
-- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
--
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
+ | do_fb_red && isNilForm env arg_list
+ -- foldl f z [] = z
-- again another short cut, helps with unroling of constant lists
- tick Foldr_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 FoldrBuild `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_isAppendForm
- = -- foldl k z (foldr (:) ys xs) <args> ==> foldl k (foldl k z xs) ys <args>
- -- be caseful with for order of xs / ys
- tick FoldrFoldr `thenSmpl_`
- newId ty1 `thenSmpl` \ other_foldl ->
- let
- inner_foldl = applyToArgs (CoVar foldlId)
- [TypeArg ty1,TypeArg ty2,
- ValArg arg_k,ValArg arg_z,ValArg xs]
- outer_foldl = applyToArgs (CoVar foldlId)
- ([TypeArg ty1,TypeArg ty2,
- ValArg arg_k,ValArg (CoVarAtom other_foldl),ValArg ys]
- ++ rest_args)
- in returnSmpl (Just (CoLet (CoNonRec other_foldl inner_foldl) outer_foldl))
+ 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.
+ = Just (tick FoldlAugment `thenSmpl_`
+ -- c :: t2 -> (t1 -> t1) -> t1 -> t1
+ -- n :: t1 -> t1
+ 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,
+ g_,
+ a,
+ a',
+ t] ->
+
+ 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 (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 Foldr_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
+ arg_list_isAugmentForm = maybeToBool augmentForm
+ augmentForm = getAugmentForm env arg_list
+ (Just (g',h)) = augmentForm
+
arg_list_isBuildForm = maybeToBool buildForm
buildForm = getBuildForm env arg_list
(Just g) = buildForm
listForm = getListForm env arg_list
(Just (the_list,the_tl)) = listForm
+{-
arg_list_isAppendForm = maybeToBool appendForm
appendForm = getAppendForm env arg_list
(Just (xs,ys)) = appendForm
+-}
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
--
- tick FoldrInline `thenSmpl_`
+ = 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"#
+--
+unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
+ | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
+ = Just (tick Str_UnpackCons `thenSmpl_`
+ returnSmpl (mkGenApp (Var unpackCStringAppendId)
+ [ValArg str,
+ ValArg arg_z])
+ )
+unpack_foldr_fun env _ = Nothing
+
+unpack_append_fun env
+ [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
+ | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
+ = Just (tick Str_UnpackNil `thenSmpl_`
+ returnSmpl (Lit (NoRepStr str_val))
+ )
+unpack_append_fun env _ = Nothing
+-}
+\end{code}
projects / ghc-hetmet.git / blobdiff