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(..) )
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}
%************************************************************************
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
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))
+ | 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) =
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
ValArg (CoVarAtom x),
ValArg (CoVarAtom z)]))
rest_args))
--}
| doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
= -- foldr k args =
-- in
-- h xs) k args
--
- tick FoldrInline `thenSmpl_`
+-- tick FoldrInline `thenSmpl_`
newIds [
ty1, -- a :: t1
mkListTy ty1, -- b :: [t1]
(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
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
| 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)
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
-- 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 [
(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) <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 = 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) =
-- 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)
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
-- in
-- h xs z) k args
--
- tick FoldrInline `thenSmpl_`
+-- tick FoldrInline `thenSmpl_`
newIds [
ty2, -- a :: t1
mkListTy ty2, -- b :: [t1]
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}
projects / ghc-hetmet.git / blobdiff