1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
\begin{code}
#include "HsVersions.h"
module FoldrBuildWW ( mkFoldrBuildWW ) where
IMPORT_Trace
import Outputable
import Pretty
import Type ( cloneTyVarFromTemplate, mkTyVarTy,
splitTypeWithDictsAsArgs, eqTyCon, mkForallTy )
import TysPrim ( alphaTy )
import TyVar ( alphaTyVar )
import Type ( 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)
-> UniqSupply
-> [CoreBinding]
-> [CoreBinding]
mkFoldrBuildWW switch us top_binds =
(mapWw wwBind top_binds `thenWw` \ top_binds2 ->
returnWw (concat top_binds2)) us switch
\end{code}
\begin{code}
wwBind :: CoreBinding -> WwM [CoreBinding]
wwBind (NonRec bndr expr)
= try_split_bind bndr expr `thenWw` \ re ->
returnWw [NonRec bnds expr | (bnds,expr) <- re]
wwBind (Rec binds)
= mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
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 (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 -> CoreExpr -> WwM [(Id,CoreExpr)]
try_split_bind id expr =
wwExpr expr `thenWw` \ expr' ->
case getFBType (getIdFBTypeInfo id) of
Just (FBType consum prod)
| FBGoodProd == prod ->
{- || any (== FBGoodConsum) consum -}
let
(use_args,big_args,args,body) = digForLambdas 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
-- -> 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 ->
let
-- The *new* type
n_ty = alphaTy
n_ty_templ = alphaTy
(templ,arg_tys,res) = splitTypeWithDictsAsArgs (idType id)
expr_ty = getListTy res
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)
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)
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
= mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
worker_body = runBuiltinUs (
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 (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
then panic "LEN PROBLEM"
else
returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
_ -> returnWw [(id,expr')]
\end{code}
|
