Commit 4cf0f63b authored by simonpj's avatar simonpj
Browse files

[project @ 1999-12-07 15:50:13 by simonpj]

Remove long-outdated AnalFBWW
parent bf33ba3a
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
\begin{code}
module AnalFBWW ( analFBWW ) where
#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
:: [CoreBind]
-> [CoreBind]
analFBWW = panic "analFBWW (ToDo)"
{- LATER:
analFBWW top_binds = trace "ANALFBWW" (snd anno)
where
anals :: [InBinding]
anals = newOccurAnalyseBinds top_binds (const False)
anno = mapAccumL annotateBindingFBWW emptyVarEnv anals
\end{code}
\begin{code}
data OurFBType
= IsFB FBType
| IsNotFB -- unknown
| IsCons -- \ xy -> (:) ty xy
| IsBottom -- _|_
deriving (Eq)
-- We only handle *reasonable* types
-- Later might add concept of bottom
-- because foldr f z (<bottom>) = <bottom>
unknownFBType = IsNotFB
goodProdFBType = IsFB (FBType [] FBGoodProd)
maybeFBtoFB (Just ty) = ty
maybeFBtoFB (Nothing) = IsNotFB
addArgs :: Int -> OurFBType -> OurFBType
addArgs n (IsFB (FBType 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
rmArg :: OurFBType -> OurFBType
rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer"
rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod)
rmArg IsBottom = IsBottom
rmArg _ = IsNotFB
joinFBType :: OurFBType -> OurFBType -> OurFBType
joinFBType (IsBottom) a = a
joinFBType a (IsBottom) = a
joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
| length args == length args' = (IsFB (FBType (zipWith{-Equal-} argJ args args')
(prodJ prod prod')))
where
argJ FBGoodConsum FBGoodConsum = FBGoodConsum
argJ _ _ = FBBadConsum
prodJ FBGoodProd FBGoodProd = FBGoodProd
prodJ _ _ = FBBadProd
joinFBType _ _ = IsNotFB
--
-- Mutter :: IdEnv FBType need to be in an *inlinable* context.
--
analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
--
-- [ build g ] is a good context
--
analExprFBWW (App (CoTyApp (Var bld) _) _) env
| bld == buildId = goodProdFBType
--
-- [ foldr (:) ys xs ] ==> good
-- (but better if xs)
--
analExprFBWW (App (App (App
(CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
env
| pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
(ppr foldr_id)
(foldr_id == foldrId && isCons c) = goodProdFBType
where
isCons c = case lookupVarEnv env c of
Just IsCons -> True
_ -> False
analExprFBWW (Var v) env = maybeFBtoFB (lookupVarEnv env v)
analExprFBWW (Lit _) _ = unknownFBType
--
-- [ x : xs ] ==> good iff [ xs ] is good
--
analExprFBWW (Con con _ [_,VarArg y]) env
| con == consDataCon = maybeFBtoFB (lookupVarEnv env y)
--
-- [] is good
--
analExprFBWW (Con con _ []) _
| con == nilDataCon = goodProdFBType
analExprFBWW (Con _ _ _) _ = unknownFBType
analExprFBWW (Prim _ _ _) _ = unknownFBType
-- \ xy -> (:) ty xy == a CONS
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 (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 (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 (delVarEnvList env (map fst binders))) alts
analAltsFBWW (PrimAlts alts deflt) env
= case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
tys = map (\(lit,e) -> analExprFBWW e env) alts
analDefFBWW NoDefault env = Nothing
analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delVarEnv env (fst v)))
\end{code}
Only add a type info if:
1. Is a functionn.
2. Is an inlineable object.
\begin{code}
analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
analBindExpr bnd expr env
= case analExprFBWW expr env of
IsFB ty@(FBType [] _) ->
if oneSafeOcc False bnd
then IsFB ty
else IsNotFB
other -> other
analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
analBind (NonRec (v,bnd) e) env =
case analBindExpr bnd e env of
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' = delVarEnvList env (map (fst.fst) binds)
in
extendVarEnvList 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'
then maps
else fixpoint (n+1) binds env maps'
where
env' = extendVarEnvList env maps
maps' = [ (v,ty) | ((v,bind),e) <- binds,
(ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
\end{code}
\begin{code}
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 (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 (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
(env',bnds') = annotateBindingFBWW env bnds
annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
where
alts' = [ let
binders' = map fst 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'
where
alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
deflt' = annotateDefFBWW deflt env
annotateDefFBWW NoDefault env = NoDefault
annotateDefFBWW (BindDefault v e) env
= BindDefault (fst v) (annotateExprFBWW e (delVarEnv env (fst v)))
annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
annotateBindingFBWW env bnds = (env',bnds')
where
env' = analBind bnds env
bnds' = case bnds of
NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
fixId v =
(case lookupVarEnv env' v of
Just (IsFB ty@(FBType xs p))
| not (null xs) -> pprTrace "ADDED to:" (ppr v)
(addIdFBTypeInfo v (mkFBTypeInfo ty))
_ -> v)
-}
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment