%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
module FoldrBuildWW ( mkFoldrBuildWW ) where
-IMPORT_Trace
-import Outputable
-import Pretty
-import AbsUniType ( alpha_tv, cloneTyVarFromTemplate, mkTyVarTy,
- splitTypeWithDictsAsArgs, eqTyCon, mkForallTy,
- alpha_tyvar, alpha_ty, alpha, TyVarTemplate
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import UniType ( UniType(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
-import PlainCore
-import Unique ( runBuiltinUs )
-import WwLib -- share the same monad (is this eticit ?)
-import AbsPrel ( listTyCon, mkListTy, nilDataCon, consDataCon,
- foldrId, mkBuild, mkFoldr, buildId,
- mkFunTy
- )
-import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
- replaceIdInfo, mkSysLocal, getIdUniType
- )
-import IdInfo
-import Maybes
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+IMP_Ubiq(){-uitous-}
+
+import CoreSyn ( SYN_IE(CoreBinding) )
+import UniqSupply ( UniqSupply )
+import Util ( panic{-ToDo:rm?-} )
+
+--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
+-- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
+--import TysPrim ( alphaTy )
+--import TyVar ( alphaTyVar )
+--
+--import Type ( SYN_IE(Type) ) -- **** CAN SEE THE CONSTRUCTORS ****
+--import UniqSupply ( runBuiltinUs )
+--import WwLib -- share the same monad (is this eticit ?)
+--import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
+-- foldrId, buildId
+-- )
+--import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
+-- replaceIdInfo, mkSysLocal, idType
+-- )
+--import IdInfo
+--import Maybes
+--import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
+--import Util
\end{code}
\begin{code}
-mkFoldrBuildWW
- :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> PlainCoreProgram
- -> PlainCoreProgram
-mkFoldrBuildWW switch us top_binds =
+mkFoldrBuildWW
+ :: UniqSupply
+ -> [CoreBinding]
+ -> [CoreBinding]
+
+mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
+
+{- LATER:
+mkFoldrBuildWW us top_binds =
(mapWw wwBind top_binds `thenWw` \ top_binds2 ->
- returnWw (concat top_binds2)) us switch
+ returnWw (concat top_binds2)) us
\end{code}
\begin{code}
-wwBind :: PlainCoreBinding -> WwM [PlainCoreBinding]
-wwBind (CoNonRec bndr expr)
+wwBind :: CoreBinding -> WwM [CoreBinding]
+wwBind (NonRec bndr expr)
= try_split_bind bndr expr `thenWw` \ re ->
- returnWw [CoNonRec bnds expr | (bnds,expr) <- re]
-wwBind (CoRec binds)
+ returnWw [NonRec bnds expr | (bnds,expr) <- re]
+wwBind (Rec binds)
= mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
- returnWw [CoRec (concat res)]
-
-wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr
-wwExpr e@(CoVar _) = returnWw e
-wwExpr e@(CoLit _) = returnWw e
-wwExpr e@(CoCon _ _ _) = returnWw e
-wwExpr e@(CoPrim _ _ _) = returnWw e
-wwExpr (CoLam ids e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoLam ids e')
-wwExpr (CoTyLam tyvar e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoTyLam tyvar e')
-wwExpr (CoApp f atom) =
- wwExpr f `thenWw` \ f' ->
- returnWw (CoApp f atom)
-wwExpr (CoTyApp f ty) =
- wwExpr f `thenWw` \ f' ->
- returnWw (CoTyApp f' ty)
-wwExpr (CoSCC lab e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoSCC lab e')
-wwExpr (CoLet bnds e) =
- wwExpr e `thenWw` \ e' ->
- wwBind bnds `thenWw` \ bnds' ->
- returnWw (foldr CoLet e' bnds')
-wwExpr (CoCase e alts) =
- wwExpr e `thenWw` \ e' ->
- wwAlts alts `thenWw` \ alts' ->
- returnWw (CoCase e' alts')
-
-wwAlts (CoAlgAlts alts deflt) =
- mapWw (\(con,binders,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (con,binders,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (CoAlgAlts alts' deflt)
-wwAlts (CoPrimAlts alts deflt) =
- mapWw (\(lit,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (lit,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (CoPrimAlts alts' deflt)
-
-wwDef e@CoNoDefault = returnWw e
-wwDef (CoBindDefault v e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoBindDefault v e')
+ returnWw [Rec (concat res)]
+
+wwExpr :: CoreExpr -> WwM CoreExpr
+wwExpr e@(Var _) = returnWw e
+wwExpr e@(Lit _) = returnWw e
+wwExpr e@(Con _ _ _) = returnWw e
+wwExpr e@(Prim _ _ _) = returnWw e
+wwExpr (Lam ids e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (Lam ids e')
+wwExpr (CoTyLam tyvar e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (CoTyLam tyvar e')
+wwExpr (App f atom) =
+ wwExpr f `thenWw` \ f' ->
+ returnWw (App f atom)
+wwExpr (CoTyApp f ty) =
+ wwExpr f `thenWw` \ f' ->
+ returnWw (CoTyApp f' ty)
+wwExpr (SCC lab e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (SCC lab e')
+wwExpr (Coerce c ty e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (Coerce c ty e')
+wwExpr (Let bnds e) =
+ wwExpr e `thenWw` \ e' ->
+ wwBind bnds `thenWw` \ bnds' ->
+ returnWw (foldr Let e' bnds')
+wwExpr (Case e alts) =
+ wwExpr e `thenWw` \ e' ->
+ wwAlts alts `thenWw` \ alts' ->
+ returnWw (Case e' alts')
+
+wwAlts (AlgAlts alts deflt) =
+ mapWw (\(con,binders,e) ->
+ wwExpr e `thenWw` \ e' ->
+ returnWw (con,binders,e')) alts `thenWw` \ alts' ->
+ wwDef deflt `thenWw` \ deflt' ->
+ returnWw (AlgAlts alts' deflt)
+wwAlts (PrimAlts alts deflt) =
+ mapWw (\(lit,e) ->
+ wwExpr e `thenWw` \ e' ->
+ returnWw (lit,e')) alts `thenWw` \ alts' ->
+ wwDef deflt `thenWw` \ deflt' ->
+ returnWw (PrimAlts alts' deflt)
+
+wwDef e@NoDefault = returnWw e
+wwDef (BindDefault v e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (BindDefault v e')
\end{code}
\begin{code}
-try_split_bind :: Id -> PlainCoreExpr -> WwM [(Id,PlainCoreExpr)]
-try_split_bind id expr =
+try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
+try_split_bind id expr =
wwExpr expr `thenWw` \ expr' ->
case getFBType (getIdFBTypeInfo id) of
- Just (FBType consum prod)
- | FBGoodProd == prod ->
+ Just (FBType consum prod)
+ | FBGoodProd == prod ->
{- || any (== FBGoodConsum) consum -}
let
- (big_args,args,body) = digForLambdas expr'
+ (use_args,big_args,args,body) = collectBinders expr'
in
- if length args /= length consum -- funny number of arguments
- then returnWw [(id,expr')]
- else
- -- f /\ t1 .. tn \ v1 .. vn -> e
- -- ===>
- -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
- -- f /\ t1 .. tn \ v1 .. vn
+ if length args /= length consum -- funny number of arguments
+ then returnWw [(id,expr')]
+ else
+ -- f /\ t1 .. tn \ v1 .. vn -> e
+ -- ===>
+ -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
+ -- f /\ t1 .. tn \ v1 .. vn
-- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
pprTrace "WW:" (ppr PprDebug id) (returnWw ())
`thenWw` \ () ->
- getUniqueWw `thenWw` \ ty_new_uq ->
- getUniqueWw `thenWw` \ worker_new_uq ->
- getUniqueWw `thenWw` \ c_new_uq ->
- getUniqueWw `thenWw` \ n_new_uq ->
+ getUniqueWw `thenWw` \ ty_new_uq ->
+ getUniqueWw `thenWw` \ worker_new_uq ->
+ getUniqueWw `thenWw` \ c_new_uq ->
+ getUniqueWw `thenWw` \ n_new_uq ->
let
-- The *new* type
- n_ty = alpha_ty
- n_ty_templ = alpha
+ n_ty = alphaTy
+ n_ty_templ = alphaTy
- (templ,arg_tys,res) = splitTypeWithDictsAsArgs (getIdUniType id)
+ (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
expr_ty = getListTy res
- getListTy res = case res of
- UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
- _ -> panic "Trying to split a non List datatype into Worker/Wrapper"
+ getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
+ UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
+ _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
- c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
- c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
+ c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
+ c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
- worker_ty = mkForallTy (templ ++ [alpha_tv])
+ worker_ty = mkForallTy (templ ++ [alphaTyVar])
(foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
- wrapper_id = id `replaceIdInfo`
- (getIdInfo id `addInfo_UF`
- iWantToBeINLINEd UnfoldAlways)
+ wrapper_id = addInlinePragma id
worker_id = mkWorkerId worker_new_uq id worker_ty
noIdInfo
-- TODO : CHECK if mkWorkerId is thr
-- right function to use ..
-- Now the bodies
-
- c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc
- n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc
- worker_rhs = foldr CoTyLam
- (mkCoLam (args++[c_id,n_id]) worker_body)
- (big_args ++ [alpha_tyvar])
+
+ c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc
+ n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc
+ worker_rhs
+ = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
+
worker_body = runBuiltinUs (
- mkCoApps (mkCoTyApps (CoVar foldrId) [expr_ty, n_ty])
- [CoVar c_id,CoVar n_id,body])
- wrapper_rhs = foldr CoTyLam
- (mkCoLam (args) wrapper_body)
- big_args
+ mkCoApps
+ (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
+ VarArg c_id `App` VarArg n_id)
+ [body])
+ wrapper_rhs = mkLam big_args args wrapper_body
+
wrapper_body = runBuiltinUs (
- mkCoApps (mkCoTyApp (CoVar buildId) expr_ty)
- [CoTyLam alpha_tyvar (mkCoLam [c_id,n_id]
- (foldl CoApp
- (mkCoTyApps (CoVar worker_id)
- [mkTyVarTy t | t <- big_args ++ [alpha_tyvar]])
- (map CoVarAtom (args++[c_id,n_id]))))])
+ mkCoApps (CoTyApp (Var buildId) expr_ty)
+ [mkLam [alphaTyVar] [c_id,n_id]
+ (foldl App
+ (mkCoTyApps (Var worker_id)
+ [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
+ (map VarArg (args++[c_id,n_id])))])
in
if length args /= length arg_tys ||
- length big_args /= length templ
+ length big_args /= length templ
then panic "LEN PROBLEM"
else
- returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
+ returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
_ -> returnWw [(id,expr')]
+-}
\end{code}
-
projects / ghc-hetmet.git / blobdiff