ghc/compiler/simplCore/AnalFBWW.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   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_Trace
  12 import Outputable
  13 import Pretty
  14
  15 import PlainCore
  16 import TaggedCore
  17 import Util
  18 import Id                       ( addIdFBTypeInfo )
  19 import IdInfo
  20 import IdEnv
  21 import AbsPrel          ( foldrId, buildId,
  22                           nilDataCon, consDataCon, mkListTy, mkFunTy,
  23                           unpackCStringAppendId
  24                         )
  25 import BinderInfo
  26 import SimplEnv         -- everything
  27 import NewOccurAnal
  28 import Maybes
  29
  30 \end{code}
  31
  32 \begin{code}
  33 analFBWW
  34         :: (GlobalSwitch -> Bool)
  35         -> PlainCoreProgram
  36         -> PlainCoreProgram
  37 analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
  38  where
  39         anals :: [InBinding]
  40         anals = newOccurAnalyseBinds top_binds switch (const False)
  41         anno = mapAccumL annotateBindingFBWW nullIdEnv anals
  42 \end{code}
  43
  44 \begin{code}
  45 data OurFBType
  46         = IsFB FBType
  47         | IsNotFB               -- unknown
  48         | IsCons                -- \ xy -> (:) ty xy
  49         | IsBottom              -- _|_
  50                 deriving (Eq)
  51         -- We only handle *reasonable* types
  52         -- Later might add concept of bottom
  53         -- because foldr f z (<bottom>) = <bottom>
  54 unknownFBType  = IsNotFB
  55 goodProdFBType = IsFB (FBType [] FBGoodProd)
  56
  57 maybeFBtoFB (Just ty) = ty
  58 maybeFBtoFB (Nothing) = IsNotFB
  59
  60 addArgs :: Int -> OurFBType -> OurFBType
  61 addArgs n (IsFB (FBType args prod))
  62         = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
  63 addArgs n IsNotFB = IsNotFB
  64 addArgs n IsCons = panic "adding argument to a cons"
  65 addArgs n IsBottom = IsNotFB
  66
  67 rmArg :: OurFBType -> OurFBType
  68 rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer"
  69 rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod)
  70 rmArg IsBottom = IsBottom
  71 rmArg _ = IsNotFB
  72
  73 joinFBType :: OurFBType -> OurFBType -> OurFBType
  74 joinFBType (IsBottom) a = a
  75 joinFBType a (IsBottom) = a
  76 joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod'))
  77         | length args == length args' = (IsFB (FBType (zipWith argJ args args')
  78                                                       (prodJ prod prod')))
  79    where
  80         argJ FBGoodConsum FBGoodConsum = FBGoodConsum
  81         argJ _            _            = FBBadConsum
  82         prodJ FBGoodProd FBGoodProd    = FBGoodProd
  83         prodJ _                   _    = FBBadProd
  84
  85 joinFBType _ _ = IsNotFB
  86
  87 --
  88 -- Mutter :: IdEnv FBType need to be in an *inlinable* context.
  89 --
  90
  91 analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType
  92
  93 --
  94 -- [ build g ]          is a good context
  95 --
  96 analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env
  97         | bld == buildId         = goodProdFBType
  98
  99 --
 100 -- [ foldr (:) ys xs ] ==> good
 101 --                      (but better if xs)
 102 --
 103 analExprFBWW (CoApp (CoApp (CoApp
 104                 (CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _)
 105                 env
 106         | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
 107                 (ppr PprDebug foldr_id)
 108                 (foldr_id == foldrId && isCons c) = goodProdFBType
 109    where
 110         isCons c = case lookupIdEnv env c of
 111                     Just IsCons -> True
 112                     _ -> False
 113 analExprFBWW (CoVar v) env       = maybeFBtoFB (lookupIdEnv env v)
 114 analExprFBWW (CoLit _) _         = unknownFBType
 115
 116 --
 117 -- [ x : xs ]  ==> good iff [ xs ] is good
 118 --
 119
 120 analExprFBWW (CoCon con _ [_,CoVarAtom y]) env
 121         | con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
 122 --
 123 -- [] is good
 124 --
 125 analExprFBWW (CoCon con _ []) _
 126         | con == nilDataCon = goodProdFBType
 127 analExprFBWW (CoCon _ _ _) _     = unknownFBType
 128 analExprFBWW (CoPrim _ _ _) _    = unknownFBType
 129
 130 -- \ xy -> (:) ty xy == a CONS
 131 analExprFBWW (CoLam [(x,_),(y,_)]
 132                 (CoCon con _ [CoVarAtom x',CoVarAtom y'])) env
 133         | con == consDataCon && x == x' && y == y'
 134         = IsCons
 135 analExprFBWW (CoLam ids e) env
 136         = addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids)))
 137 analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
 138 analExprFBWW (CoApp f atom) env  = rmArg (analExprFBWW f env)
 139 analExprFBWW (CoTyApp f ty) env  = analExprFBWW f env
 140 analExprFBWW (CoSCC lab e) env   = analExprFBWW e env
 141 analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env)
 142 analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
 143
 144 analAltsFBWW (CoAlgAlts 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 (CoPrimAlts 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 CoNoDefault env = Nothing
 159 analDefFBWW (CoBindDefault 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 (CoNonRec (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 (CoRec binds) env =
 186    let
 187         first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
 188                                 (_,args,_) <- [digForLambdas 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 -> PlainCoreExpr
 208 annotateExprFBWW (CoVar v) env = CoVar v
 209 annotateExprFBWW (CoLit i) env = CoLit i
 210 annotateExprFBWW (CoCon c t a) env = CoCon c t a
 211 annotateExprFBWW (CoPrim p t a) env = CoPrim p t a
 212 annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids'))
 213    where ids' = map fst ids
 214 annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
 215 annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom
 216 annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
 217 annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env)
 218 annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env)
 219                                             (annotateAltsFBWW alts env)
 220 annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env')
 221   where
 222         (env',bnds') = annotateBindingFBWW env bnds
 223
 224 annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt'
 225   where
 226         alts' = [ let
 227                    binders' = map fst binders
 228                   in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
 229                                 | (con,binders,e) <- alts ]
 230         deflt' = annotateDefFBWW deflt env
 231 annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt'
 232   where
 233         alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
 234         deflt' = annotateDefFBWW deflt env
 235
 236 annotateDefFBWW CoNoDefault env = CoNoDefault
 237 annotateDefFBWW (CoBindDefault v e) env
 238         = CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
 239
 240 annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding)
 241 annotateBindingFBWW env bnds = (env',bnds')
 242   where
 243         env' = analBind bnds env
 244         bnds' = case bnds of
 245                   CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env)
 246                   CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
 247         fixId v =
 248                 (case lookupIdEnv env' v of
 249                    Just (IsFB ty@(FBType xs p))
 250                     | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
 251                                         (addIdFBTypeInfo v (mkFBTypeInfo ty))
 252                    _ -> v)
 253 \end{code}