%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
\begin{code}
-#include "HsVersions.h"
-
module AnalFBWW ( analFBWW ) where
-import Util
-import Id ( addIdFBTypeInfo )
-import IdInfo
-import PrelInfo ( foldrId, buildId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId
- )
-import BinderInfo
-import SimplEnv -- everything
-import OccurAnal -- OLD: was NewOccurAnal
-import Maybes
+#include "HsVersions.h"
+-- Just a stub for now
+import CoreSyn ( CoreBind )
+import Panic ( panic )
+
+--import Util
+--import Id ( addIdFBTypeInfo )
+--import IdInfo
+--import PrelInfo ( foldrId, buildId,
+-- nilDataCon, consDataCon, mkListTy, mkFunTy,
+-- unpackCStringAppendId
+-- )
+--import BinderInfo
+--import SimplEnv -- everything
+--import OccurAnal -- OLD: was NewOccurAnal
+--import Maybes
\end{code}
\begin{code}
analFBWW
- :: (GlobalSwitch -> Bool)
- -> [CoreBinding]
- -> [CoreBinding]
-analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
+ :: [CoreBind]
+ -> [CoreBind]
+
+analFBWW = panic "analFBWW (ToDo)"
+
+{- LATER:
+analFBWW top_binds = trace "ANALFBWW" (snd anno)
where
anals :: [InBinding]
- anals = newOccurAnalyseBinds top_binds switch (const False)
- anno = mapAccumL annotateBindingFBWW nullIdEnv anals
+ anals = newOccurAnalyseBinds top_binds (const False)
+ anno = mapAccumL annotateBindingFBWW emptyVarEnv anals
\end{code}
\begin{code}
addArgs :: Int -> OurFBType -> OurFBType
addArgs n (IsFB (FBType args prod))
- = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
+ = IsFB (FBType (nOfThem n FBBadConsum ++ args) prod)
addArgs n IsNotFB = IsNotFB
addArgs n IsCons = panic "adding argument to a cons"
addArgs n IsBottom = IsNotFB
joinFBType (IsBottom) a = a
joinFBType a (IsBottom) = a
joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
- | length args == length args' = (IsFB (FBType (zipWith argJ args args')
+ | length args == length args' = (IsFB (FBType (zipWith{-Equal-} argJ args args')
(prodJ prod prod')))
where
argJ FBGoodConsum FBGoodConsum = FBGoodConsum
(CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
env
| pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
- (ppr PprDebug foldr_id)
+ (ppr foldr_id)
(foldr_id == foldrId && isCons c) = goodProdFBType
where
- isCons c = case lookupIdEnv env c of
+ isCons c = case lookupVarEnv env c of
Just IsCons -> True
_ -> False
-analExprFBWW (Var v) env = maybeFBtoFB (lookupIdEnv env v)
+analExprFBWW (Var v) env = maybeFBtoFB (lookupVarEnv env v)
analExprFBWW (Lit _) _ = unknownFBType
--
--
analExprFBWW (Con con _ [_,VarArg y]) env
- | con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
+ | con == consDataCon = maybeFBtoFB (lookupVarEnv env y)
--
-- [] is good
--
| con == consDataCon && x == x' && y == y'
= IsCons
analExprFBWW (Lam (id,_) e) env
- = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
+ = addArgs 1 (analExprFBWW e (delVarEnv env id))
analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
-analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
-analExprFBWW (CoTyApp f ty) env = analExprFBWW f 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 (AlgAlts alts deflt) env =
- case analDefFBWW deflt env of
+analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
+analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
+analExprFBWW (Note _ 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 (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 (PrimAlts alts deflt) env =
- case analDefFBWW deflt env of
+ tys = map (\(con,binders,e) -> analExprFBWW e (delVarEnvList env (map fst binders))) alts
+analAltsFBWW (PrimAlts alts deflt) env
+ = case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
analDefFBWW NoDefault env = Nothing
-analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
+analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delVarEnv env (fst v)))
\end{code}
\begin{code}
analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
-analBindExpr bnd expr env =
- case analExprFBWW expr env of
+analBindExpr bnd expr env
+ = case analExprFBWW expr env of
IsFB ty@(FBType [] _) ->
if oneSafeOcc False bnd
then IsFB ty
analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
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!
+ ty@(IsFB _) -> extendVarEnv env v ty
+ ty@(IsCons) -> extendVarEnv env v ty
+ _ -> delVarEnv env v -- remember about shadowing!
analBind (Rec binds) env =
let
first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
- (_,_,args,_) <- [collectBinders e]]
- env' = delManyFromIdEnv env (map (fst.fst) binds)
+ (_,args,_) <- [collectBinders e]]
+ env' = delVarEnvList env (map (fst.fst) binds)
in
- growIdEnvList env' (fixpoint 0 binds env' first_set)
+ extendVarEnvList env' (fixpoint 0 binds env' first_set)
fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
fixpoint n binds env maps =
then maps
else fixpoint (n+1) binds env maps'
where
- env' = growIdEnvList env maps
+ env' = extendVarEnvList env maps
maps' = [ (v,ty) | ((v,bind),e) <- binds,
(ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
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))
+ = Lam id (annotateExprFBWW e (delVarEnv env id))
annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
-annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
+annotateExprFBWW (Note note e) env = Note note (annotateExprFBWW e env)
annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
(annotateAltsFBWW alts env)
annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
where
alts' = [ let
binders' = map fst binders
- in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
+ in (con,binders',annotateExprFBWW e (delVarEnvList env binders'))
| (con,binders,e) <- alts ]
deflt' = annotateDefFBWW deflt env
annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
annotateDefFBWW NoDefault env = NoDefault
annotateDefFBWW (BindDefault v e) env
- = BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
+ = BindDefault (fst v) (annotateExprFBWW e (delVarEnv env (fst v)))
annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
annotateBindingFBWW env bnds = (env',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
+ (case lookupVarEnv env' v of
Just (IsFB ty@(FBType xs p))
- | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
+ | not (null xs) -> pprTrace "ADDED to:" (ppr v)
(addIdFBTypeInfo v (mkFBTypeInfo ty))
_ -> v)
+-}
\end{code}
projects / ghc-hetmet.git / blobdiff