2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
7 module FoldrBuildWW ( mkFoldrBuildWW ) where
9 #include "HsVersions.h"
11 -- Just a stub for now
12 import CoreSyn ( CoreBind )
13 import UniqSupply ( UniqSupply )
14 import Panic ( panic )
16 --import Type ( cloneTyVarFromTemplate, mkTyVarTy,
17 -- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
18 --import TysPrim ( alphaTy )
19 --import TyVar ( alphaTyVar )
21 --import Type ( Type ) -- **** CAN SEE THE CONSTRUCTORS ****
22 --import UniqSupply ( runBuiltinUs )
23 --import WwLib -- share the same monad (is this eticit ?)
24 --import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
27 --import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
32 --import SrcLoc ( noSrcLoc, SrcLoc )
42 mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
45 mkFoldrBuildWW us top_binds =
46 (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
47 returnWw (concat top_binds2)) us
51 wwBind :: CoreBinding -> WwM [CoreBinding]
52 wwBind (NonRec bndr expr)
53 = try_split_bind bndr expr `thenWw` \ re ->
54 returnWw [NonRec bnds expr | (bnds,expr) <- re]
56 = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
57 returnWw [Rec (concat res)]
59 wwExpr :: CoreExpr -> WwM CoreExpr
60 wwExpr e@(Var _) = returnWw e
61 wwExpr e@(Lit _) = returnWw e
62 wwExpr e@(Con _ _ _) = returnWw e
63 wwExpr e@(Prim _ _ _) = returnWw e
65 wwExpr e `thenWw` \ e' ->
67 wwExpr (CoTyLam tyvar e) =
68 wwExpr e `thenWw` \ e' ->
69 returnWw (CoTyLam tyvar e')
71 wwExpr f `thenWw` \ f' ->
73 wwExpr (CoTyApp f ty) =
74 wwExpr f `thenWw` \ f' ->
75 returnWw (CoTyApp f' ty)
76 wwExpr (Note note e) =
77 wwExpr e `thenWw` \ e' ->
78 returnWw (Note note e')
80 wwExpr e `thenWw` \ e' ->
81 wwBind bnds `thenWw` \ bnds' ->
82 returnWw (foldr Let e' bnds')
83 wwExpr (Case e alts) =
84 wwExpr e `thenWw` \ e' ->
85 wwAlts alts `thenWw` \ alts' ->
86 returnWw (Case e' alts')
88 wwAlts (AlgAlts alts deflt) =
89 mapWw (\(con,binders,e) ->
90 wwExpr e `thenWw` \ e' ->
91 returnWw (con,binders,e')) alts `thenWw` \ alts' ->
92 wwDef deflt `thenWw` \ deflt' ->
93 returnWw (AlgAlts alts' deflt)
94 wwAlts (PrimAlts alts deflt) =
96 wwExpr e `thenWw` \ e' ->
97 returnWw (lit,e')) alts `thenWw` \ alts' ->
98 wwDef deflt `thenWw` \ deflt' ->
99 returnWw (PrimAlts alts' deflt)
101 wwDef e@NoDefault = returnWw e
102 wwDef (BindDefault v e) =
103 wwExpr e `thenWw` \ e' ->
104 returnWw (BindDefault v e')
108 try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
109 try_split_bind id expr =
110 wwExpr expr `thenWw` \ expr' ->
111 case getFBType (getIdFBTypeInfo id) of
112 Just (FBType consum prod)
113 | FBGoodProd == prod ->
114 {- || any (== FBGoodConsum) consum -}
116 (big_args,args,body) = collectBinders expr'
118 if length args /= length consum -- funny number of arguments
119 then returnWw [(id,expr')]
121 -- f /\ t1 .. tn \ v1 .. vn -> e
123 -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
124 -- f /\ t1 .. tn \ v1 .. vn
125 -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
126 pprTrace "WW:" (ppr id) (returnWw ())
128 getUniqueWw `thenWw` \ ty_new_uq ->
129 getUniqueWw `thenWw` \ worker_new_uq ->
130 getUniqueWw `thenWw` \ c_new_uq ->
131 getUniqueWw `thenWw` \ n_new_uq ->
137 (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
138 expr_ty = getListTy res
139 getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
140 UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
141 _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
143 c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
144 c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
146 worker_ty = mkForallTy (templ ++ [alphaTyVar])
147 (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
148 wrapper_id = setInlinePragma id IWantToBeINLINEd
149 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
155 n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty
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')]