ghc/compiler/simplCore/AnalFBWW.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
   5
   6 \begin{code}
   7 module AnalFBWW ( analFBWW ) where
   8
   9 #include "HsVersions.h"
  10
  11 -- Just a stub for now
  12 import CoreSyn          ( CoreBind )
  13 import Util             ( panic )
  14
  15 --import Util
  16 --import Id                     ( addIdFBTypeInfo )
  17 --import IdInfo
  18 --import PrelInfo          ( foldrId, buildId,
  19 --                        nilDataCon, consDataCon, mkListTy, mkFunTy,
  20 --                        unpackCStringAppendId
  21 --                      )
  22 --import BinderInfo
  23 --import SimplEnv               -- everything
  24 --import OccurAnal      -- OLD: was NewOccurAnal
  25 --import Maybes
  26 \end{code}
  27
  28 \begin{code}
  29 analFBWW
  30         :: [CoreBind]
  31         -> [CoreBind]
  32
  33 analFBWW = panic "analFBWW (ToDo)"
  34
  35 {- LATER:
  36 analFBWW top_binds = trace "ANALFBWW" (snd anno)
  37  where
  38         anals :: [InBinding]
  39         anals = newOccurAnalyseBinds top_binds (const False)
  40         anno = mapAccumL annotateBindingFBWW emptyVarEnv anals
  41 \end{code}
  42
  43 \begin{code}
  44 data OurFBType
  45         = IsFB FBType
  46         | IsNotFB               -- unknown
  47         | IsCons                -- \ xy -> (:) ty xy
  48         | IsBottom              -- _|_
  49                 deriving (Eq)
  50         -- We only handle *reasonable* types
  51         -- Later might add concept of bottom
  52         -- because foldr f z (<bottom>) = <bottom>
  53 unknownFBType  = IsNotFB
  54 goodProdFBType = IsFB (FBType [] FBGoodProd)
  55
  56 maybeFBtoFB (Just ty) = ty
  57 maybeFBtoFB (Nothing) = IsNotFB
  58
  59 addArgs :: Int -> OurFBType -> OurFBType
  60 addArgs n (IsFB (FBType args prod))
  61         = IsFB (FBType (nOfThem n FBBadConsum ++ args) prod)
  62 addArgs n IsNotFB = IsNotFB
  63 addArgs n IsCons = panic "adding argument to a cons"
  64 addArgs n IsBottom = IsNotFB
  65
  66 rmArg :: OurFBType -> OurFBType
  67 rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer"
  68 rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod)
  69 rmArg IsBottom = IsBottom
  70 rmArg _ = IsNotFB
  71
  72 joinFBType :: OurFBType -> OurFBType -> OurFBType
  73 joinFBType (IsBottom) a = a
  74 joinFBType a (IsBottom) = a
  75 joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
  76         | length args == length args' = (IsFB (FBType (zipWith{-Equal-} argJ args args')
  77                                                       (prodJ prod prod')))
  78    where
  79         argJ FBGoodConsum FBGoodConsum = FBGoodConsum
  80         argJ _            _            = FBBadConsum
  81         prodJ FBGoodProd FBGoodProd    = FBGoodProd
  82         prodJ _                   _    = FBBadProd
  83
  84 joinFBType _ _ = IsNotFB
  85
  86 --
  87 -- Mutter :: IdEnv FBType need to be in an *inlinable* context.
  88 --
  89
  90 analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
  91
  92 --
  93 -- [ build g ]          is a good context
  94 --
  95 analExprFBWW (App (CoTyApp (Var bld) _) _) env
  96         | bld == buildId         = goodProdFBType
  97
  98 --
  99 -- [ foldr (:) ys xs ] ==> good
 100 --                      (but better if xs)
 101 --
 102 analExprFBWW (App (App (App
 103                 (CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
 104                 env
 105         | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
 106                 (ppr foldr_id)
 107                 (foldr_id == foldrId && isCons c) = goodProdFBType
 108    where
 109         isCons c = case lookupVarEnv env c of
 110                     Just IsCons -> True
 111                     _ -> False
 112 analExprFBWW (Var v) env       = maybeFBtoFB (lookupVarEnv env v)
 113 analExprFBWW (Lit _) _         = unknownFBType
 114
 115 --
 116 -- [ x : xs ]  ==> good iff [ xs ] is good
 117 --
 118
 119 analExprFBWW (Con con _ [_,VarArg y]) env
 120         | con == consDataCon = maybeFBtoFB (lookupVarEnv env y)
 121 --
 122 -- [] is good
 123 --
 124 analExprFBWW (Con con _ []) _
 125         | con == nilDataCon = goodProdFBType
 126 analExprFBWW (Con _ _ _) _     = unknownFBType
 127 analExprFBWW (Prim _ _ _) _    = unknownFBType
 128
 129 -- \ xy -> (:) ty xy == a CONS
 130
 131 analExprFBWW (Lam (x,_) (Lam (y,_)
 132                 (Con con _ [VarArg x',VarArg y']))) env
 133   | con == consDataCon && x == x' && y == y'
 134   = IsCons
 135 analExprFBWW (Lam (id,_) e) env
 136   = addArgs 1 (analExprFBWW e (delVarEnv env id))
 137
 138 analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
 139 analExprFBWW (App f atom) env   = rmArg (analExprFBWW f env)
 140 analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
 141 analExprFBWW (Note _ e) env     = analExprFBWW e env
 142 analExprFBWW (Let binds e) env  = analExprFBWW e (analBind binds env)
 143 analExprFBWW (Case e alts) env  = foldl1 joinFBType (analAltsFBWW alts env)
 144
 145 analAltsFBWW (AlgAlts alts deflt) env
 146   = case analDefFBWW deflt env of
 147         Just ty -> ty : tys
 148         Nothing -> tys
 149    where
 150      tys = map (\(con,binders,e) -> analExprFBWW e (delVarEnvList env (map fst binders))) alts
 151 analAltsFBWW (PrimAlts alts deflt) env
 152   = case analDefFBWW deflt env of
 153         Just ty -> ty : tys
 154         Nothing -> tys
 155    where
 156      tys = map (\(lit,e) -> analExprFBWW e env) alts
 157
 158
 159 analDefFBWW NoDefault env = Nothing
 160 analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delVarEnv env (fst v)))
 161 \end{code}
 162
 163
 164 Only add a type info if:
 165
 166 1. Is a functionn.
 167 2. Is an inlineable object.
 168
 169 \begin{code}
 170 analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
 171 analBindExpr bnd expr env
 172   =    case analExprFBWW expr env of
 173               IsFB ty@(FBType [] _) ->
 174                    if oneSafeOcc False bnd
 175                    then IsFB ty
 176                    else IsNotFB
 177               other -> other
 178
 179 analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
 180 analBind (NonRec (v,bnd) e) env =
 181         case analBindExpr bnd e env of
 182          ty@(IsFB _) -> extendVarEnv env v ty
 183          ty@(IsCons) -> extendVarEnv env v ty
 184          _ -> delVarEnv env v   -- remember about shadowing!
 185
 186 analBind (Rec binds) env =
 187    let
 188         first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
 189                                 (_,args,_) <- [collectBinders e]]
 190         env' = delVarEnvList env (map (fst.fst) binds)
 191    in
 192         extendVarEnvList env' (fixpoint 0 binds env' first_set)
 193
 194 fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
 195 fixpoint n binds env maps =
 196         if maps == maps'
 197         then maps
 198         else fixpoint (n+1) binds env maps'
 199    where
 200         env' = extendVarEnvList env maps
 201         maps' = [ (v,ty) | ((v,bind),e) <- binds,
 202                         (ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
 203
 204 \end{code}
 205
 206
 207 \begin{code}
 208 annotateExprFBWW :: InExpr -> IdEnv OurFBType -> CoreExpr
 209 annotateExprFBWW (Var v) env = Var v
 210 annotateExprFBWW (Lit i) env = Lit i
 211 annotateExprFBWW (Con c t a) env = Con c t a
 212 annotateExprFBWW (Prim p t a) env = Prim p t a
 213 annotateExprFBWW (Lam (id,_) e) env
 214   = Lam id (annotateExprFBWW e (delVarEnv env id))
 215
 216 annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
 217 annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
 218 annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
 219 annotateExprFBWW (Note note e) env = Note note (annotateExprFBWW e env)
 220 annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
 221                                             (annotateAltsFBWW alts env)
 222 annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
 223   where
 224         (env',bnds') = annotateBindingFBWW env bnds
 225
 226 annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
 227   where
 228         alts' = [ let
 229                    binders' = map fst binders
 230                   in (con,binders',annotateExprFBWW e (delVarEnvList env binders'))
 231                                 | (con,binders,e) <- alts ]
 232         deflt' = annotateDefFBWW deflt env
 233 annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
 234   where
 235         alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
 236         deflt' = annotateDefFBWW deflt env
 237
 238 annotateDefFBWW NoDefault env = NoDefault
 239 annotateDefFBWW (BindDefault v e) env
 240         = BindDefault (fst v) (annotateExprFBWW e (delVarEnv env (fst v)))
 241
 242 annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
 243 annotateBindingFBWW env bnds = (env',bnds')
 244   where
 245         env' = analBind bnds env
 246         bnds' = case bnds of
 247                   NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
 248                   Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
 249         fixId v =
 250                 (case lookupVarEnv env' v of
 251                    Just (IsFB ty@(FBType xs p))
 252                     | not (null xs) -> pprTrace "ADDED to:" (ppr v)
 253                                         (addIdFBTypeInfo v (mkFBTypeInfo ty))
 254                    _ -> v)
 255 -}
 256 \end{code}