X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FMagicUFs.lhs;fp=ghc%2Fcompiler%2FsimplCore%2FMagicUFs.lhs;h=0f29a90a0fa32bf85a0a9b3cd246080ee09f72ec;hb=e0befe921f5bbfa6daba3f8ff46cdf2a2abad1da;hp=e1e75d0a7616218b5401ecec29876f5d5a676468;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index e1e75d0..0f29a90 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -20,9 +20,10 @@ module MagicUFs ( IMPORT_Trace -- ToDo: not sure why this is being used -import AbsPrel ( foldlId, foldrId, buildId, +import AbsPrel ( foldlId, foldrId, buildId, augmentId, nilDataCon, consDataCon, mkListTy, mkFunTy, - unpackCStringAppendId + unpackCStringAppendId, unpackCStringFoldrId, + appendId ) import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate ) import BasicLit ( BasicLit(..) ) @@ -85,9 +86,12 @@ applyMagicUnfoldingFun (MUF fun) env args = fun env args 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} %************************************************************************ @@ -119,26 +123,48 @@ build_fun env [TypeArg ty,ValArg (CoVarAtom e)] build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild)) returnSmpl Nothing +\end{code} --- Now foldr, the way we consume lists. +\begin{code} +augment_fun :: SimplEnv + -> [PlainCoreArg] + -> SmplM (Maybe PlainCoreExpr) +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))) +-- 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 +\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" --} + foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args) - | isConsFun env arg_k && isNilForm env arg_z + | 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_` + tick Foldr_Cons_Nil `thenSmpl_` newId (mkListTy ty1) `thenSmpl` \ x -> returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar 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 @@ -153,20 +179,18 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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) ==> foldr k (foldr k z ys) xs - -- 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)) + | 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) + [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)))) | do_fb_red && arg_list_isListForm = -- foldr k z (a:b:c:rest) = @@ -212,26 +236,46 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list returnSmpl (Just (applyToArgs (CoLam [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) + (TypeArg ty2: + ValArg (CoLitAtom (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 + | doing_inlining && isConsFun env arg_k && not dont_fold_back_append = -- foldr (:) z xs = xs ++ z - tick FoldrCons `thenSmpl_` + tick Foldr_Cons `thenSmpl_` newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] -> returnSmpl (Just (applyToArgs (CoLam [z,x] (applyToArgs @@ -240,7 +284,6 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) ValArg (CoVarAtom x), ValArg (CoVarAtom z)])) rest_args)) --} | doing_inlining && (isInterestingArg env arg_k || isConsFun env arg_k) = -- foldr k args = @@ -252,7 +295,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) -- in -- h xs) k args -- - tick FoldrInline `thenSmpl_` +-- tick FoldrInline `thenSmpl_` newIds [ ty1, -- a :: t1 mkListTy ty1, -- b :: [t1] @@ -284,6 +327,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) (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 @@ -310,12 +354,34 @@ 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 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 getBuildForm env _ = Nothing + + +getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom) +getAugmentForm env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm False _ _ _ -> Nothing + -- not allowed to inline :-( + GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _) + (CoVarAtom 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 env _ = Nothing + +{- getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id) getAppendForm env (CoVarAtom v) = case lookupUnfolding env v of @@ -324,6 +390,7 @@ getAppendForm env (CoVarAtom v) = | 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) @@ -353,10 +420,10 @@ isInterestingArg env (CoVarAtom v) = 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 + | 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_` + tick Foldl_Nil `thenSmpl_` returnSmpl (Just (atomToExpr arg_z)) | do_fb_red && arg_list_isBuildForm @@ -365,7 +432,7 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list -- n {- INLINE -} = \ a -> a -- in g t1 c n z -- this next line *is* the foldr/build rule proper. - tick FoldrBuild `thenSmpl_` + tick FoldlBuild `thenSmpl_` -- c :: t2 -> (t1 -> t1) -> t1 -> t1 -- n :: t1 -> t1 newIds [ @@ -397,21 +464,54 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list (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) + -- 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_` + -- 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, + pre_n, + pre_r, + b, + g_, + a, + a', + t] -> - | do_fb_red && arg_list_isAppendForm - = -- foldl k z (foldr (:) ys xs) ==> foldl k (foldl k z xs) ys - -- 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 = 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), + 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)))))) | do_fb_red && arg_list_isListForm = -- foldl k z (a:b:c:rest) = @@ -430,7 +530,7 @@ 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 Foldr_List `thenSmpl_` + tick Foldl_List `thenSmpl_` newIds ( ty1 `mkFunTy` (ty2 `mkFunTy` ty1) : take (length the_list) (repeat ty1) @@ -460,6 +560,10 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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 @@ -468,9 +572,11 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list 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 @@ -484,7 +590,7 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) -- in -- h xs z) k args -- - tick FoldrInline `thenSmpl_` +-- tick FoldrInline `thenSmpl_` newIds [ ty2, -- a :: t1 mkListTy ty2, -- b :: [t1] @@ -523,3 +629,23 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) foldl_fun env _ = returnSmpl 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 + = tick Str_UnpackCons `thenSmpl_` + returnSmpl (Just (applyToArgs (CoVar unpackCStringAppendId) + [ValArg str, + ValArg arg_z])) +unpack_foldr_fun env _ = returnSmpl Nothing + +unpack_append_fun env + [ValArg (CoLitAtom (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 +\end{code}