ghc/compiler/simplCore/AnalFBWW.lhs

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