2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
7 #include "HsVersions.h"
9 module AnalFBWW ( analFBWW ) where
12 import Id ( addIdFBTypeInfo )
14 import PrelInfo ( foldrId, buildId,
15 nilDataCon, consDataCon, mkListTy, mkFunTy,
19 import SimplEnv -- everything
20 import OccurAnal -- OLD: was NewOccurAnal
27 :: (GlobalSwitch -> Bool)
30 analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
33 anals = newOccurAnalyseBinds top_binds switch (const False)
34 anno = mapAccumL annotateBindingFBWW nullIdEnv anals
41 | IsCons -- \ xy -> (:) ty xy
44 -- We only handle *reasonable* types
45 -- Later might add concept of bottom
46 -- because foldr f z (<bottom>) = <bottom>
47 unknownFBType = IsNotFB
48 goodProdFBType = IsFB (FBType [] FBGoodProd)
50 maybeFBtoFB (Just ty) = ty
51 maybeFBtoFB (Nothing) = IsNotFB
53 addArgs :: Int -> OurFBType -> OurFBType
54 addArgs n (IsFB (FBType args prod))
55 = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
56 addArgs n IsNotFB = IsNotFB
57 addArgs n IsCons = panic "adding argument to a cons"
58 addArgs n IsBottom = IsNotFB
60 rmArg :: OurFBType -> OurFBType
61 rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer"
62 rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod)
63 rmArg IsBottom = IsBottom
66 joinFBType :: OurFBType -> OurFBType -> OurFBType
67 joinFBType (IsBottom) a = a
68 joinFBType a (IsBottom) = a
69 joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
70 | length args == length args' = (IsFB (FBType (zipWith argJ args args')
73 argJ FBGoodConsum FBGoodConsum = FBGoodConsum
74 argJ _ _ = FBBadConsum
75 prodJ FBGoodProd FBGoodProd = FBGoodProd
78 joinFBType _ _ = IsNotFB
81 -- Mutter :: IdEnv FBType need to be in an *inlinable* context.
84 analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
87 -- [ build g ] is a good context
89 analExprFBWW (App (CoTyApp (Var bld) _) _) env
90 | bld == buildId = goodProdFBType
93 -- [ foldr (:) ys xs ] ==> good
96 analExprFBWW (App (App (App
97 (CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
99 | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
100 (ppr PprDebug foldr_id)
101 (foldr_id == foldrId && isCons c) = goodProdFBType
103 isCons c = case lookupIdEnv env c of
106 analExprFBWW (Var v) env = maybeFBtoFB (lookupIdEnv env v)
107 analExprFBWW (Lit _) _ = unknownFBType
110 -- [ x : xs ] ==> good iff [ xs ] is good
113 analExprFBWW (Con con _ [_,VarArg y]) env
114 | con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
118 analExprFBWW (Con con _ []) _
119 | con == nilDataCon = goodProdFBType
120 analExprFBWW (Con _ _ _) _ = unknownFBType
121 analExprFBWW (Prim _ _ _) _ = unknownFBType
123 -- \ xy -> (:) ty xy == a CONS
125 analExprFBWW (Lam (x,_) (Lam (y,_)
126 (Con con _ [VarArg x',VarArg y']))) env
127 | con == consDataCon && x == x' && y == y'
129 analExprFBWW (Lam (id,_) e) env
130 = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
132 analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
133 analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
134 analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
135 analExprFBWW (SCC lab e) env = analExprFBWW e env
136 analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
137 analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
139 analAltsFBWW (AlgAlts alts deflt) env =
140 case analDefFBWW deflt env of
144 tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
145 analAltsFBWW (PrimAlts alts deflt) env =
146 case analDefFBWW deflt env of
150 tys = map (\(lit,e) -> analExprFBWW e env) alts
153 analDefFBWW NoDefault env = Nothing
154 analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
158 Only add a type info if:
161 2. Is an inlineable object.
164 analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
165 analBindExpr bnd expr env =
166 case analExprFBWW expr env of
167 IsFB ty@(FBType [] _) ->
168 if oneSafeOcc False bnd
173 analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
174 analBind (NonRec (v,bnd) e) env =
175 case analBindExpr bnd e env of
176 ty@(IsFB _) -> addOneToIdEnv env v ty
177 ty@(IsCons) -> addOneToIdEnv env v ty
178 _ -> delOneFromIdEnv env v -- remember about shadowing!
180 analBind (Rec binds) env =
182 first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
183 (_,_,args,_) <- [digForLambdas e]]
184 env' = delManyFromIdEnv env (map (fst.fst) binds)
186 growIdEnvList env' (fixpoint 0 binds env' first_set)
188 fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
189 fixpoint n binds env maps =
192 else fixpoint (n+1) binds env maps'
194 env' = growIdEnvList env maps
195 maps' = [ (v,ty) | ((v,bind),e) <- binds,
196 (ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
202 annotateExprFBWW :: InExpr -> IdEnv OurFBType -> CoreExpr
203 annotateExprFBWW (Var v) env = Var v
204 annotateExprFBWW (Lit i) env = Lit i
205 annotateExprFBWW (Con c t a) env = Con c t a
206 annotateExprFBWW (Prim p t a) env = Prim p t a
207 annotateExprFBWW (Lam (id,_) e) env
208 = Lam id (annotateExprFBWW e (delOneFromIdEnv env id))
210 annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
211 annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
212 annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
213 annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
214 annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
215 (annotateAltsFBWW alts env)
216 annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
218 (env',bnds') = annotateBindingFBWW env bnds
220 annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
223 binders' = map fst binders
224 in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
225 | (con,binders,e) <- alts ]
226 deflt' = annotateDefFBWW deflt env
227 annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
229 alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
230 deflt' = annotateDefFBWW deflt env
232 annotateDefFBWW NoDefault env = NoDefault
233 annotateDefFBWW (BindDefault v e) env
234 = BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
236 annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
237 annotateBindingFBWW env bnds = (env',bnds')
239 env' = analBind bnds env
241 NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
242 Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
244 (case lookupIdEnv env' v of
245 Just (IsFB ty@(FBType xs p))
246 | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
247 (addIdFBTypeInfo v (mkFBTypeInfo ty))