2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
7 module FoldrBuildWW ( mkFoldrBuildWW ) where
9 #include "HsVersions.h"
11 import CoreSyn ( CoreBinding )
12 import UniqSupply ( UniqSupply )
13 import Util ( panic{-ToDo:rm?-} )
15 --import Type ( cloneTyVarFromTemplate, mkTyVarTy,
16 -- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
17 --import TysPrim ( alphaTy )
18 --import TyVar ( alphaTyVar )
20 --import Type ( Type ) -- **** CAN SEE THE CONSTRUCTORS ****
21 --import UniqSupply ( runBuiltinUs )
22 --import WwLib -- share the same monad (is this eticit ?)
23 --import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
26 --import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
27 -- replaceIdInfo, mkSysLocal, idType
31 --import SrcLoc ( noSrcLoc, SrcLoc )
41 mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
44 mkFoldrBuildWW us top_binds =
45 (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
46 returnWw (concat top_binds2)) us
50 wwBind :: CoreBinding -> WwM [CoreBinding]
51 wwBind (NonRec bndr expr)
52 = try_split_bind bndr expr `thenWw` \ re ->
53 returnWw [NonRec bnds expr | (bnds,expr) <- re]
55 = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
56 returnWw [Rec (concat res)]
58 wwExpr :: CoreExpr -> WwM CoreExpr
59 wwExpr e@(Var _) = returnWw e
60 wwExpr e@(Lit _) = returnWw e
61 wwExpr e@(Con _ _ _) = returnWw e
62 wwExpr e@(Prim _ _ _) = returnWw e
64 wwExpr e `thenWw` \ e' ->
66 wwExpr (CoTyLam tyvar e) =
67 wwExpr e `thenWw` \ e' ->
68 returnWw (CoTyLam tyvar e')
70 wwExpr f `thenWw` \ f' ->
72 wwExpr (CoTyApp f ty) =
73 wwExpr f `thenWw` \ f' ->
74 returnWw (CoTyApp f' ty)
75 wwExpr (Note note e) =
76 wwExpr e `thenWw` \ e' ->
77 returnWw (Note note e')
79 wwExpr e `thenWw` \ e' ->
80 wwBind bnds `thenWw` \ bnds' ->
81 returnWw (foldr Let e' bnds')
82 wwExpr (Case e alts) =
83 wwExpr e `thenWw` \ e' ->
84 wwAlts alts `thenWw` \ alts' ->
85 returnWw (Case e' alts')
87 wwAlts (AlgAlts alts deflt) =
88 mapWw (\(con,binders,e) ->
89 wwExpr e `thenWw` \ e' ->
90 returnWw (con,binders,e')) alts `thenWw` \ alts' ->
91 wwDef deflt `thenWw` \ deflt' ->
92 returnWw (AlgAlts alts' deflt)
93 wwAlts (PrimAlts alts deflt) =
95 wwExpr e `thenWw` \ e' ->
96 returnWw (lit,e')) alts `thenWw` \ alts' ->
97 wwDef deflt `thenWw` \ deflt' ->
98 returnWw (PrimAlts alts' deflt)
100 wwDef e@NoDefault = returnWw e
101 wwDef (BindDefault v e) =
102 wwExpr e `thenWw` \ e' ->
103 returnWw (BindDefault v e')
107 try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
108 try_split_bind id expr =
109 wwExpr expr `thenWw` \ expr' ->
110 case getFBType (getIdFBTypeInfo id) of
111 Just (FBType consum prod)
112 | FBGoodProd == prod ->
113 {- || any (== FBGoodConsum) consum -}
115 (big_args,args,body) = collectBinders expr'
117 if length args /= length consum -- funny number of arguments
118 then returnWw [(id,expr')]
120 -- f /\ t1 .. tn \ v1 .. vn -> e
122 -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
123 -- f /\ t1 .. tn \ v1 .. vn
124 -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
125 pprTrace "WW:" (ppr id) (returnWw ())
127 getUniqueWw `thenWw` \ ty_new_uq ->
128 getUniqueWw `thenWw` \ worker_new_uq ->
129 getUniqueWw `thenWw` \ c_new_uq ->
130 getUniqueWw `thenWw` \ n_new_uq ->
136 (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
137 expr_ty = getListTy res
138 getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
139 UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
140 _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
142 c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
143 c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
145 worker_ty = mkForallTy (templ ++ [alphaTyVar])
146 (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
147 wrapper_id = addInlinePragma id
148 worker_id = mkWorkerId worker_new_uq id worker_ty
150 -- TODO : CHECK if mkWorkerId is thr
151 -- right function to use ..
154 c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc
155 n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc
157 = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
159 worker_body = runBuiltinUs (
161 (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
162 VarArg c_id `App` VarArg n_id)
164 wrapper_rhs = mkLam big_args args wrapper_body
166 wrapper_body = runBuiltinUs (
167 mkCoApps (CoTyApp (Var buildId) expr_ty)
168 [mkLam [alphaTyVar] [c_id,n_id]
170 (mkCoTyApps (Var worker_id)
171 [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
172 (map VarArg (args++[c_id,n_id])))])
175 if length args /= length arg_tys ||
176 length big_args /= length templ
177 then panic "LEN PROBLEM"
179 returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
180 _ -> returnWw [(id,expr')]