2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
7 #include "HsVersions.h"
9 module FoldrBuildWW ( mkFoldrBuildWW ) where
13 import CoreSyn ( SYN_IE(CoreBinding) )
14 import UniqSupply ( UniqSupply )
15 import Util ( panic{-ToDo:rm?-} )
17 --import Type ( cloneTyVarFromTemplate, mkTyVarTy,
18 -- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
19 --import TysPrim ( alphaTy )
20 --import TyVar ( alphaTyVar )
22 --import Type ( SYN_IE(Type) ) -- **** CAN SEE THE CONSTRUCTORS ****
23 --import UniqSupply ( runBuiltinUs )
24 --import WwLib -- share the same monad (is this eticit ?)
25 --import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
28 --import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
29 -- replaceIdInfo, mkSysLocal, idType
33 --import SrcLoc ( noSrcLoc, SrcLoc )
43 mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
46 mkFoldrBuildWW us top_binds =
47 (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
48 returnWw (concat top_binds2)) us
52 wwBind :: CoreBinding -> WwM [CoreBinding]
53 wwBind (NonRec bndr expr)
54 = try_split_bind bndr expr `thenWw` \ re ->
55 returnWw [NonRec bnds expr | (bnds,expr) <- re]
57 = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
58 returnWw [Rec (concat res)]
60 wwExpr :: CoreExpr -> WwM CoreExpr
61 wwExpr e@(Var _) = returnWw e
62 wwExpr e@(Lit _) = returnWw e
63 wwExpr e@(Con _ _ _) = returnWw e
64 wwExpr e@(Prim _ _ _) = returnWw e
66 wwExpr e `thenWw` \ e' ->
68 wwExpr (CoTyLam tyvar e) =
69 wwExpr e `thenWw` \ e' ->
70 returnWw (CoTyLam tyvar e')
72 wwExpr f `thenWw` \ f' ->
74 wwExpr (CoTyApp f ty) =
75 wwExpr f `thenWw` \ f' ->
76 returnWw (CoTyApp f' ty)
78 wwExpr e `thenWw` \ e' ->
80 wwExpr (Coerce c ty e) =
81 wwExpr e `thenWw` \ e' ->
82 returnWw (Coerce c ty e')
84 wwExpr e `thenWw` \ e' ->
85 wwBind bnds `thenWw` \ bnds' ->
86 returnWw (foldr Let e' bnds')
87 wwExpr (Case e alts) =
88 wwExpr e `thenWw` \ e' ->
89 wwAlts alts `thenWw` \ alts' ->
90 returnWw (Case e' alts')
92 wwAlts (AlgAlts alts deflt) =
93 mapWw (\(con,binders,e) ->
94 wwExpr e `thenWw` \ e' ->
95 returnWw (con,binders,e')) alts `thenWw` \ alts' ->
96 wwDef deflt `thenWw` \ deflt' ->
97 returnWw (AlgAlts alts' deflt)
98 wwAlts (PrimAlts alts deflt) =
100 wwExpr e `thenWw` \ e' ->
101 returnWw (lit,e')) alts `thenWw` \ alts' ->
102 wwDef deflt `thenWw` \ deflt' ->
103 returnWw (PrimAlts alts' deflt)
105 wwDef e@NoDefault = returnWw e
106 wwDef (BindDefault v e) =
107 wwExpr e `thenWw` \ e' ->
108 returnWw (BindDefault v e')
112 try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
113 try_split_bind id expr =
114 wwExpr expr `thenWw` \ expr' ->
115 case getFBType (getIdFBTypeInfo id) of
116 Just (FBType consum prod)
117 | FBGoodProd == prod ->
118 {- || any (== FBGoodConsum) consum -}
120 (use_args,big_args,args,body) = collectBinders expr'
122 if length args /= length consum -- funny number of arguments
123 then returnWw [(id,expr')]
125 -- f /\ t1 .. tn \ v1 .. vn -> e
127 -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
128 -- f /\ t1 .. tn \ v1 .. vn
129 -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
130 pprTrace "WW:" (ppr PprDebug id) (returnWw ())
132 getUniqueWw `thenWw` \ ty_new_uq ->
133 getUniqueWw `thenWw` \ worker_new_uq ->
134 getUniqueWw `thenWw` \ c_new_uq ->
135 getUniqueWw `thenWw` \ n_new_uq ->
141 (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
142 expr_ty = getListTy res
143 getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
144 UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
145 _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
147 c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
148 c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
150 worker_ty = mkForallTy (templ ++ [alphaTyVar])
151 (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
152 wrapper_id = addInlinePragma id
153 worker_id = mkWorkerId worker_new_uq id worker_ty
155 -- TODO : CHECK if mkWorkerId is thr
156 -- right function to use ..
159 c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc
160 n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc
162 = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
164 worker_body = runBuiltinUs (
166 (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
167 VarArg c_id `App` VarArg n_id)
169 wrapper_rhs = mkLam big_args args wrapper_body
171 wrapper_body = runBuiltinUs (
172 mkCoApps (CoTyApp (Var buildId) expr_ty)
173 [mkLam [alphaTyVar] [c_id,n_id]
175 (mkCoTyApps (Var worker_id)
176 [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
177 (map VarArg (args++[c_id,n_id])))])
180 if length args /= length arg_tys ||
181 length big_args /= length templ
182 then panic "LEN PROBLEM"
184 returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
185 _ -> returnWw [(id,expr')]