2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
7 #include "HsVersions.h"
9 module AnalFBWW ( analFBWW ) where
18 import Id ( addIdFBTypeInfo )
21 import AbsPrel ( foldrId, buildId,
22 nilDataCon, consDataCon, mkListTy, mkFunTy,
26 import SimplEnv -- everything
34 :: (GlobalSwitch -> Bool)
37 analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
40 anals = newOccurAnalyseBinds top_binds switch (const False)
41 anno = mapAccumL annotateBindingFBWW nullIdEnv anals
48 | IsCons -- \ xy -> (:) ty xy
51 -- We only handle *reasonable* types
52 -- Later might add concept of bottom
53 -- because foldr f z (<bottom>) = <bottom>
54 unknownFBType = IsNotFB
55 goodProdFBType = IsFB (FBType [] FBGoodProd)
57 maybeFBtoFB (Just ty) = ty
58 maybeFBtoFB (Nothing) = IsNotFB
60 addArgs :: Int -> OurFBType -> OurFBType
61 addArgs n (IsFB (FBType args prod))
62 = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
63 addArgs n IsNotFB = IsNotFB
64 addArgs n IsCons = panic "adding argument to a cons"
65 addArgs n IsBottom = IsNotFB
67 rmArg :: OurFBType -> OurFBType
68 rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer"
69 rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod)
70 rmArg IsBottom = IsBottom
73 joinFBType :: OurFBType -> OurFBType -> OurFBType
74 joinFBType (IsBottom) a = a
75 joinFBType a (IsBottom) = a
76 joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
77 | length args == length args' = (IsFB (FBType (zipWith argJ args args')
80 argJ FBGoodConsum FBGoodConsum = FBGoodConsum
81 argJ _ _ = FBBadConsum
82 prodJ FBGoodProd FBGoodProd = FBGoodProd
85 joinFBType _ _ = IsNotFB
88 -- Mutter :: IdEnv FBType need to be in an *inlinable* context.
91 analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
94 -- [ build g ] is a good context
96 analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env
97 | bld == buildId = goodProdFBType
100 -- [ foldr (:) ys xs ] ==> good
101 -- (but better if xs)
103 analExprFBWW (CoApp (CoApp (CoApp
104 (CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _)
106 | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
107 (ppr PprDebug foldr_id)
108 (foldr_id == foldrId && isCons c) = goodProdFBType
110 isCons c = case lookupIdEnv env c of
113 analExprFBWW (CoVar v) env = maybeFBtoFB (lookupIdEnv env v)
114 analExprFBWW (CoLit _) _ = unknownFBType
117 -- [ x : xs ] ==> good iff [ xs ] is good
120 analExprFBWW (CoCon con _ [_,CoVarAtom y]) env
121 | con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
125 analExprFBWW (CoCon con _ []) _
126 | con == nilDataCon = goodProdFBType
127 analExprFBWW (CoCon _ _ _) _ = unknownFBType
128 analExprFBWW (CoPrim _ _ _) _ = unknownFBType
130 -- \ xy -> (:) ty xy == a CONS
131 analExprFBWW (CoLam [(x,_),(y,_)]
132 (CoCon con _ [CoVarAtom x',CoVarAtom y'])) env
133 | con == consDataCon && x == x' && y == y'
135 analExprFBWW (CoLam ids e) env
136 = addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids)))
137 analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
138 analExprFBWW (CoApp f atom) env = rmArg (analExprFBWW f env)
139 analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
140 analExprFBWW (CoSCC lab e) env = analExprFBWW e env
141 analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env)
142 analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
144 analAltsFBWW (CoAlgAlts alts deflt) env =
145 case analDefFBWW deflt env of
149 tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
150 analAltsFBWW (CoPrimAlts alts deflt) env =
151 case analDefFBWW deflt env of
155 tys = map (\(lit,e) -> analExprFBWW e env) alts
158 analDefFBWW CoNoDefault env = Nothing
159 analDefFBWW (CoBindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
163 Only add a type info if:
166 2. Is an inlineable object.
169 analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
170 analBindExpr bnd expr env =
171 case analExprFBWW expr env of
172 IsFB ty@(FBType [] _) ->
173 if oneSafeOcc False bnd
178 analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
179 analBind (CoNonRec (v,bnd) e) env =
180 case analBindExpr bnd e env of
181 ty@(IsFB _) -> addOneToIdEnv env v ty
182 ty@(IsCons) -> addOneToIdEnv env v ty
183 _ -> delOneFromIdEnv env v -- remember about shadowing!
185 analBind (CoRec binds) env =
187 first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
188 (_,args,_) <- [digForLambdas e]]
189 env' = delManyFromIdEnv env (map (fst.fst) binds)
191 growIdEnvList env' (fixpoint 0 binds env' first_set)
193 fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
194 fixpoint n binds env maps =
197 else fixpoint (n+1) binds env maps'
199 env' = growIdEnvList env maps
200 maps' = [ (v,ty) | ((v,bind),e) <- binds,
201 (ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
207 annotateExprFBWW :: InExpr -> IdEnv OurFBType -> PlainCoreExpr
208 annotateExprFBWW (CoVar v) env = CoVar v
209 annotateExprFBWW (CoLit i) env = CoLit i
210 annotateExprFBWW (CoCon c t a) env = CoCon c t a
211 annotateExprFBWW (CoPrim p t a) env = CoPrim p t a
212 annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids'))
213 where ids' = map fst ids
214 annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
215 annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom
216 annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
217 annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env)
218 annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env)
219 (annotateAltsFBWW alts env)
220 annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env')
222 (env',bnds') = annotateBindingFBWW env bnds
224 annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt'
227 binders' = map fst binders
228 in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
229 | (con,binders,e) <- alts ]
230 deflt' = annotateDefFBWW deflt env
231 annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt'
233 alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
234 deflt' = annotateDefFBWW deflt env
236 annotateDefFBWW CoNoDefault env = CoNoDefault
237 annotateDefFBWW (CoBindDefault v e) env
238 = CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
240 annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding)
241 annotateBindingFBWW env bnds = (env',bnds')
243 env' = analBind bnds env
245 CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env)
246 CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
248 (case lookupIdEnv env' v of
249 Just (IsFB ty@(FBType xs p))
250 | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
251 (addIdFBTypeInfo v (mkFBTypeInfo ty))