X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FMagicUFs.lhs;h=77e43ae687aedc346800da232be19553cf5994c2;hp=0f29a90a0fa32bf85a0a9b3cd246080ee09f72ec;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=e0befe921f5bbfa6daba3f8ff46cdf2a2abad1da diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index 0f29a90..77e43ae 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -1,5 +1,5 @@ % -% (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} @@ -7,37 +7,23 @@ #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} %************************************************************************ @@ -49,29 +35,31 @@ import Util \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} @@ -83,6 +71,8 @@ applyMagicUnfoldingFun (MUF fun) env args = fun env args %************************************************************************ \begin{code} +{- LATER: + magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)] magic_UFs_table @@ -90,8 +80,8 @@ 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} %************************************************************************ @@ -104,103 +94,107 @@ magic_UFs_table -- 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 @@ -208,46 +202,46 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list -- 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 @@ -274,21 +268,23 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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) @@ -296,99 +292,97 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) -- 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 -} @@ -398,52 +392,53 @@ 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', @@ -451,39 +446,41 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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, @@ -492,36 +489,37 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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: @@ -530,32 +528,32 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list -- 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 @@ -579,73 +577,78 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list -} 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}