%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
module AnalFBWW ( analFBWW ) where
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import PlainCore
-import TaggedCore
import Util
import Id ( addIdFBTypeInfo )
-import IdInfo
-import IdEnv
-import AbsPrel ( foldrId, buildId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId
- )
+import IdInfo
+import PrelInfo ( foldrId, buildId,
+ nilDataCon, consDataCon, mkListTy, mkFunTy,
+ unpackCStringAppendId
+ )
import BinderInfo
import SimplEnv -- everything
-import NewOccurAnal
+import OccurAnal -- OLD: was NewOccurAnal
import Maybes
\end{code}
\begin{code}
-analFBWW
- :: (GlobalSwitch -> Bool)
- -> PlainCoreProgram
- -> PlainCoreProgram
+analFBWW
+ :: (GlobalSwitch -> Bool)
+ -> [CoreBinding]
+ -> [CoreBinding]
analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
where
anals :: [InBinding]
\end{code}
\begin{code}
-data OurFBType
+data OurFBType
= IsFB FBType
| IsNotFB -- unknown
| IsCons -- \ xy -> (:) ty xy
deriving (Eq)
-- We only handle *reasonable* types
-- Later might add concept of bottom
- -- because foldr f z (<bottom>) = <bottom>
+ -- because foldr f z (<bottom>) = <bottom>
unknownFBType = IsNotFB
goodProdFBType = IsFB (FBType [] FBGoodProd)
maybeFBtoFB (Nothing) = IsNotFB
addArgs :: Int -> OurFBType -> OurFBType
-addArgs n (IsFB (FBType args prod))
+addArgs n (IsFB (FBType args prod))
= IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
addArgs n IsNotFB = IsNotFB
addArgs n IsCons = panic "adding argument to a cons"
--
-- [ build g ] is a good context
--
-analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env
+analExprFBWW (App (CoTyApp (Var bld) _) _) env
| bld == buildId = goodProdFBType
--
-- [ foldr (:) ys xs ] ==> good
-- (but better if xs)
--
-analExprFBWW (CoApp (CoApp (CoApp
- (CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _)
- env
+analExprFBWW (App (App (App
+ (CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
+ env
| pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
(ppr PprDebug foldr_id)
(foldr_id == foldrId && isCons c) = goodProdFBType
isCons c = case lookupIdEnv env c of
Just IsCons -> True
_ -> False
-analExprFBWW (CoVar v) env = maybeFBtoFB (lookupIdEnv env v)
-analExprFBWW (CoLit _) _ = unknownFBType
+analExprFBWW (Var v) env = maybeFBtoFB (lookupIdEnv env v)
+analExprFBWW (Lit _) _ = unknownFBType
--
-- [ x : xs ] ==> good iff [ xs ] is good
--
-analExprFBWW (CoCon con _ [_,CoVarAtom y]) env
+analExprFBWW (Con con _ [_,VarArg y]) env
| con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
--
-- [] is good
--
-analExprFBWW (CoCon con _ []) _
+analExprFBWW (Con con _ []) _
| con == nilDataCon = goodProdFBType
-analExprFBWW (CoCon _ _ _) _ = unknownFBType
-analExprFBWW (CoPrim _ _ _) _ = unknownFBType
+analExprFBWW (Con _ _ _) _ = unknownFBType
+analExprFBWW (Prim _ _ _) _ = unknownFBType
-- \ xy -> (:) ty xy == a CONS
-analExprFBWW (CoLam [(x,_),(y,_)]
- (CoCon con _ [CoVarAtom x',CoVarAtom y'])) env
- | con == consDataCon && x == x' && y == y'
- = IsCons
-analExprFBWW (CoLam ids e) env
- = addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids)))
+
+analExprFBWW (Lam (x,_) (Lam (y,_)
+ (Con con _ [VarArg x',VarArg y']))) env
+ | con == consDataCon && x == x' && y == y'
+ = IsCons
+analExprFBWW (Lam (id,_) e) env
+ = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
+
analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
-analExprFBWW (CoApp f atom) env = rmArg (analExprFBWW f env)
+analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
-analExprFBWW (CoSCC lab e) env = analExprFBWW e env
-analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env)
-analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
+analExprFBWW (SCC lab e) env = analExprFBWW e env
+analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
+analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
-analAltsFBWW (CoAlgAlts alts deflt) env =
+analAltsFBWW (AlgAlts alts deflt) env =
case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
-analAltsFBWW (CoPrimAlts alts deflt) env =
+analAltsFBWW (PrimAlts alts deflt) env =
case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
tys = map (\(lit,e) -> analExprFBWW e env) alts
-analDefFBWW CoNoDefault env = Nothing
-analDefFBWW (CoBindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
+analDefFBWW NoDefault env = Nothing
+analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
\end{code}
\begin{code}
analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
-analBindExpr bnd expr env =
+analBindExpr bnd expr env =
case analExprFBWW expr env of
- IsFB ty@(FBType [] _) ->
+ IsFB ty@(FBType [] _) ->
if oneSafeOcc False bnd
then IsFB ty
else IsNotFB
other -> other
analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
-analBind (CoNonRec (v,bnd) e) env =
+analBind (NonRec (v,bnd) e) env =
case analBindExpr bnd e env of
ty@(IsFB _) -> addOneToIdEnv env v ty
ty@(IsCons) -> addOneToIdEnv env v ty
_ -> delOneFromIdEnv env v -- remember about shadowing!
-analBind (CoRec binds) env =
+analBind (Rec binds) env =
let
first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
- (_,args,_) <- [digForLambdas e]]
+ (_,_,args,_) <- [digForLambdas e]]
env' = delManyFromIdEnv env (map (fst.fst) binds)
in
growIdEnvList env' (fixpoint 0 binds env' first_set)
fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
-fixpoint n binds env maps =
- if maps == maps'
+fixpoint n binds env maps =
+ if maps == maps'
then maps
else fixpoint (n+1) binds env maps'
where
\begin{code}
-annotateExprFBWW :: InExpr -> IdEnv OurFBType -> PlainCoreExpr
-annotateExprFBWW (CoVar v) env = CoVar v
-annotateExprFBWW (CoLit i) env = CoLit i
-annotateExprFBWW (CoCon c t a) env = CoCon c t a
-annotateExprFBWW (CoPrim p t a) env = CoPrim p t a
-annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids'))
- where ids' = map fst ids
+annotateExprFBWW :: InExpr -> IdEnv OurFBType -> CoreExpr
+annotateExprFBWW (Var v) env = Var v
+annotateExprFBWW (Lit i) env = Lit i
+annotateExprFBWW (Con c t a) env = Con c t a
+annotateExprFBWW (Prim p t a) env = Prim p t a
+annotateExprFBWW (Lam (id,_) e) env
+ = Lam id (annotateExprFBWW e (delOneFromIdEnv env id))
+
annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
-annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom
+annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
-annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env)
-annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env)
+annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
+annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
(annotateAltsFBWW alts env)
-annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env')
+annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
where
- (env',bnds') = annotateBindingFBWW env bnds
+ (env',bnds') = annotateBindingFBWW env bnds
-annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt'
+annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
where
alts' = [ let
binders' = map fst binders
in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
| (con,binders,e) <- alts ]
deflt' = annotateDefFBWW deflt env
-annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt'
+annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
where
alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
deflt' = annotateDefFBWW deflt env
-annotateDefFBWW CoNoDefault env = CoNoDefault
-annotateDefFBWW (CoBindDefault v e) env
- = CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
+annotateDefFBWW NoDefault env = NoDefault
+annotateDefFBWW (BindDefault v e) env
+ = BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
-annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding)
+annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
annotateBindingFBWW env bnds = (env',bnds')
where
env' = analBind bnds env
bnds' = case bnds of
- CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env)
- CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
+ NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
+ Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
fixId v =
(case lookupIdEnv env' v of
Just (IsFB ty@(FBType xs p))
| not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
- (addIdFBTypeInfo v (mkFBTypeInfo ty))
+ (addIdFBTypeInfo v (mkFBTypeInfo ty))
_ -> v)
\end{code}
projects / ghc-hetmet.git / blobdiff