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