ghc/compiler/simplStg/UpdAnal.lhs

   1 \section{Update Avoidance Analyser}
   2
   3 (c) Simon Marlow, Andre Santos 1992-1993
   4 (c) The AQUA Project, Glasgow University, 1995-1998
   5
   6 %-----------------------------------------------------------------------------
   7 \subsection{Module Interface}
   8
   9
  10 \begin{code}
  11 module UpdAnal ( updateAnalyse ) where
  12
  13 #include  "HsVersions.h"
  14
  15 import Prelude hiding ( lookup )
  16
  17 import StgSyn
  18 import VarEnv
  19 import VarSet
  20 import Id               ( mkSysLocal,
  21                           idUpdateInfo, setIdUpdateInfo, idType,
  22                           externallyVisibleId,
  23                           Id
  24                         )
  25 import IdInfo           ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
  26 import Name             ( isLocallyDefined )
  27 import Type             ( splitFunTys, splitSigmaTy )
  28 import Unique           ( getBuiltinUniques )
  29 import Panic            ( panic )
  30 \end{code}
  31
  32
  33 %-----------------------------------------------------------------------------
  34 \subsection{Reverse application}
  35
  36 This is used instead of lazy pattern bindings to avoid space leaks.
  37
  38 \begin{code}
  39 infixr 3 =:
  40 a =: k = k a
  41 \end{code}
  42
  43 %-----------------------------------------------------------------------------
  44 \subsection{Types}
  45
  46 List of closure references
  47
  48 \begin{code}
  49 type Refs = IdSet
  50 x `notInRefs` y = not (x `elemVarSet` y)
  51 \end{code}
  52
  53 A closure value: environment of closures that are evaluated on entry,
  54 a list of closures that are referenced from the result, and an
  55 abstract value for the evaluated closure.
  56
  57 An IdEnv is used for the reference counts, as these environments are
  58 combined often. A generic environment is used for the main environment
  59 mapping closure names to values; as a common operation is extension of
  60 this environment, this representation should be efficient.
  61
  62 \begin{code}
  63 -- partain: funny synonyms to cope w/ the fact
  64 -- that IdEnvs know longer know what their keys are
  65 -- (94/05)  ToDo: improve
  66 type IdEnvInt       = IdEnv (Id, Int)
  67 type IdEnvClosure = IdEnv (Id, Closure)
  68
  69 -- backward-compat functions
  70 null_IdEnv :: IdEnv (Id, a)
  71 null_IdEnv = emptyVarEnv
  72
  73 unit_IdEnv :: Id -> a -> IdEnv (Id, a)
  74 unit_IdEnv k v = unitVarEnv k (k, v)
  75
  76 mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
  77 mk_IdEnv pairs = mkVarEnv [ (k, (k,v)) | (k,v) <- pairs ]
  78
  79 grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  80 grow_IdEnv env1 env2 = plusVarEnv env1 env2
  81
  82 addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
  83 addOneTo_IdEnv env k v = extendVarEnv env k (k, v)
  84
  85 combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  86 combine_IdEnvs combiner env1 env2 = plusVarEnv_C new_combiner env1 env2
  87   where
  88     new_combiner (id, x) (_, y) = (id, combiner x y)
  89
  90 dom_IdEnv :: IdEnv (Id, a) -> Refs
  91 dom_IdEnv env = mkVarSet [ i | (i,_) <- rngVarEnv env ]
  92
  93 lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
  94 lookup_IdEnv env key = case lookupVarEnv env key of
  95                            Nothing    -> Nothing
  96                            Just (_,a) -> Just a
  97 -- end backward compat stuff
  98
  99 type Closure = (IdEnvInt, Refs, AbFun)
 100
 101 type AbVal = IdEnvClosure -> Closure
 102 newtype AbFun = Fun (Closure -> Closure)
 103
 104 -- partain: speeding-up stuff
 105
 106 type CaseBoundVars = IdSet
 107 noCaseBound   = emptyVarSet
 108 isCaseBound   = elemVarSet
 109 x `notCaseBound` y = not (isCaseBound x y)
 110 moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
 111 moreCaseBound old new = old `unionVarSet` mkVarSet new
 112
 113 -- end speeding-up
 114 \end{code}
 115
 116 %----------------------------------------------------------------------------
 117 \subsection{Environment lookup}
 118
 119 If the requested value is not in the environment, we return an unknown
 120 value.  Lookup is designed to be partially applied to a variable, and
 121 repeatedly applied to different environments after that.
 122
 123 \begin{code}
 124 lookup v
 125   | isLocallyDefined v
 126   = \p -> case lookup_IdEnv p v of
 127                 Just b  -> b
 128                 Nothing -> unknownClosure
 129
 130   | otherwise
 131   = const (case updateInfoMaybe (idUpdateInfo v) of
 132                 Nothing   -> unknownClosure
 133                 Just spec -> convertUpdateSpec spec)
 134 \end{code}
 135
 136 %-----------------------------------------------------------------------------
 137 Represent a list of references as an ordered list.
 138
 139 \begin{code}
 140 mkRefs :: [Id] -> Refs
 141 mkRefs = mkVarSet
 142
 143 noRefs :: Refs
 144 noRefs = emptyVarSet
 145
 146 elemRefs = elemVarSet
 147
 148 merge :: [Refs] -> Refs
 149 merge xs = foldr merge2 emptyVarSet xs
 150
 151 merge2 :: Refs -> Refs -> Refs
 152 merge2 = unionVarSet
 153 \end{code}
 154
 155 %-----------------------------------------------------------------------------
 156 \subsection{Some non-interesting values}
 157
 158 bottom will be used for abstract values that are not functions.
 159 Hopefully its value will never be required!
 160
 161 \begin{code}
 162 bottom          :: AbFun
 163 bottom          = panic "Internal: (Update Analyser) bottom"
 164 \end{code}
 165
 166 noClosure is a value that is definitely not a function (i.e. primitive
 167 values and constructor applications).  unknownClosure is a value about
 168 which we have no information at all.  This should occur rarely, but
 169 could happen when an id is imported and the exporting module was not
 170 compiled with the update analyser.
 171
 172 \begin{code}
 173 noClosure, unknownClosure :: Closure
 174 noClosure               = (null_IdEnv, noRefs, bottom)
 175 unknownClosure  = (null_IdEnv, noRefs, dont_know noRefs)
 176 \end{code}
 177
 178 dont_know is a black hole: it is something we know nothing about.
 179 Applying dont_know to anything will generate a new dont_know that simply
 180 contains more buried references.
 181
 182 \begin{code}
 183 dont_know :: Refs -> AbFun
 184 dont_know b'
 185         = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b'
 186                          in (null_IdEnv, b'', dont_know b''))
 187 \end{code}
 188
 189 -----------------------------------------------------------------------------
 190
 191 \begin{code}
 192 getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs
 193 getrefs p vs rest = foldr merge2 rest  (getrefs' (map ($ p) vs))
 194         where
 195                 getrefs' []           = []
 196                 getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs
 197 \end{code}
 198
 199 -----------------------------------------------------------------------------
 200
 201 udData is used when we are putting a list of closure references into a
 202 data structure, or something else that we know nothing about.
 203
 204 \begin{code}
 205 udData :: [StgArg] -> CaseBoundVars -> AbVal
 206 udData vs cvs
 207         = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
 208         where local_ids = [ lookup v | StgVarArg v <- vs, v `notCaseBound` cvs ]
 209 \end{code}
 210
 211 %-----------------------------------------------------------------------------
 212 \subsection{Analysing an atom}
 213
 214 \begin{code}
 215 udVar :: CaseBoundVars -> Id -> AbVal
 216 udVar cvs v | v `isCaseBound` cvs = const unknownClosure
 217             | otherwise           = lookup v
 218
 219 udAtom :: CaseBoundVars -> StgArg -> AbVal
 220 udAtom cvs (StgVarArg v) = udVar cvs v
 221 udAtom cvs _             = const noClosure
 222 \end{code}
 223
 224 %-----------------------------------------------------------------------------
 225 \subsection{Analysing an STG expression}
 226
 227 \begin{code}
 228 ud :: StgExpr                   -- Expression to be analysed
 229    -> CaseBoundVars                     -- List of case-bound vars
 230    -> IdEnvClosure                      -- Current environment
 231    -> (StgExpr, AbVal)          -- (New expression, abstract value)
 232
 233 ud e@(StgLit _)           cvs p = (e, udData [] cvs)
 234 ud e@(StgConApp  _ vs)    cvs p = (e, udData vs cvs)
 235 ud e@(StgPrimApp  _ vs _) cvs p = (e, udData vs cvs)
 236 ud e@(StgSCC lab a)       cvs p = ud a cvs p =: \(a', abval_a) ->
 237                                   (StgSCC lab a', abval_a)
 238 \end{code}
 239
 240 Here is application. The first thing to do is analyse the head, and
 241 get an abstract function. Multiple applications are performed by using
 242 a foldl with the function doApp. Closures are actually passed to the
 243 abstract function iff the atom is a local variable.
 244
 245 I've left the type signature for doApp in to make things a bit clearer.
 246
 247 \begin{code}
 248 ud e@(StgApp a atoms) cvs p
 249   = (e, abval_app)
 250   where
 251     abval_atoms = map (udAtom cvs) atoms
 252     abval_a     = udVar cvs a
 253     abval_app = \p ->
 254         let doApp :: Closure -> AbVal -> Closure
 255             doApp (c, b, Fun f) abval_atom =
 256                   abval_atom p          =: \e@(_,_,_)    ->
 257                   f e                   =: \(c', b', f') ->
 258                   (combine_IdEnvs (+) c' c, b', f')
 259         in foldl doApp (abval_a p) abval_atoms
 260
 261 ud (StgCase expr lve lva bndr srt alts) cvs p
 262   = ud expr cvs p                       =: \(expr', abval_selector)  ->
 263     udAlt alts p                        =: \(alts', abval_alts) ->
 264     let
 265         abval_case = \p ->
 266           abval_selector p              =: \(c, b, abfun_selector) ->
 267           abval_alts p                  =: \(cs, bs, abfun_alts)   ->
 268           let bs' = b `merge2` bs in
 269           (combine_IdEnvs (+) c cs, bs', dont_know bs')
 270     in
 271     (StgCase expr' lve lva bndr srt alts', abval_case)
 272   where
 273
 274     alts_cvs = moreCaseBound cvs [bndr]
 275
 276     udAlt :: StgCaseAlts
 277           -> IdEnvClosure
 278           -> (StgCaseAlts, AbVal)
 279
 280     udAlt (StgAlgAlts ty [alt] StgNoDefault) p
 281         = udAlgAlt p alt                =: \(alt', abval) ->
 282             (StgAlgAlts ty [alt'] StgNoDefault, abval)
 283     udAlt (StgAlgAlts ty [] def) p
 284         = udDef def p                   =: \(def', abval) ->
 285           (StgAlgAlts ty [] def', abval)
 286     udAlt (StgAlgAlts ty alts def) p
 287         = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p
 288     udAlt (StgPrimAlts ty [alt] StgNoDefault) p
 289         = udPrimAlt p alt               =: \(alt', abval) ->
 290           (StgPrimAlts ty [alt'] StgNoDefault, abval)
 291     udAlt (StgPrimAlts ty [] def) p
 292         = udDef def p                   =: \(def', abval) ->
 293           (StgPrimAlts ty [] def', abval)
 294     udAlt (StgPrimAlts ty alts def) p
 295         = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
 296
 297     udPrimAlt p (l, e)
 298       = ud e alts_cvs p         =: \(e', v) -> ((l, e'), v)
 299
 300     udAlgAlt p (id, vs, use_mask, e)
 301       = ud e (moreCaseBound alts_cvs vs) p
 302                                 =: \(e', v) -> ((id, vs, use_mask, e'), v)
 303
 304     udDef :: StgCaseDefault
 305           -> IdEnvClosure
 306           -> (StgCaseDefault, AbVal)
 307
 308     udDef StgNoDefault p
 309       = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
 310     udDef (StgBindDefault expr) p
 311       = ud expr alts_cvs p      =: \(expr', abval) ->
 312           (StgBindDefault expr', abval)
 313
 314     udManyAlts alts def udalt stgalts p
 315         = udDef def p                           =: \(def', abval_def) ->
 316           unzip (map (udalt p) alts)            =: \(alts', abvals_alts) ->
 317           let
 318                 abval_alts = \p ->
 319                   abval_def p                    =: \(cd, bd, _) ->
 320                   unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) ->
 321                   let bs' = merge (bd:bs) in
 322                   (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs')
 323           in (stgalts alts' def', abval_alts)
 324 \end{code}
 325
 326 The heart of the analysis: here we decide whether to make a specific
 327 closure updatable or not, based on the results of analysing the body.
 328
 329 \begin{code}
 330 ud (StgLet binds body) cvs p
 331  = udBinding binds cvs p                =: \(binds', vs, abval1, abval2) ->
 332    abval1 p                             =: \(cs, p') ->
 333    grow_IdEnv p p'                      =: \p ->
 334    ud body cvs p                        =: \(body', abval_body) ->
 335    abval_body   p                       =: \(c, b, abfun) ->
 336    tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
 337    let
 338       abval p
 339           = abval2 p                            =: \(c1, p')       ->
 340             abval_body (grow_IdEnv p p')        =: \(c2, b, abfun) ->
 341             (combine_IdEnvs (+) c1 c2, b, abfun)
 342    in
 343    (StgLet tagged_binds body', abval)
 344 \end{code}
 345
 346 %-----------------------------------------------------------------------------
 347 \subsection{Analysing bindings}
 348
 349 For recursive sets of bindings we perform one iteration of a fixed
 350 point algorithm, using (dont_know fv) as a safe approximation to the
 351 real fixed point, where fv are the (mappings in the environment of
 352 the) free variables of the function.
 353
 354 We'll return two new environments, one with the new closures in and
 355 one without. There's no point in carrying around closures when their
 356 respective bindings have already been analysed.
 357
 358 We don't need to find anything out about closures with arguments,
 359 constructor closures etc.
 360
 361 \begin{code}
 362 udBinding :: StgBinding
 363             -> CaseBoundVars
 364           -> IdEnvClosure
 365             -> (StgBinding,
 366                 [Id],
 367                 IdEnvClosure -> (IdEnvInt, IdEnvClosure),
 368                 IdEnvClosure -> (IdEnvInt, IdEnvClosure))
 369
 370 udBinding (StgNonRec v rhs) cvs p
 371   = udRhs rhs cvs p                     =: \(rhs', abval) ->
 372     abval p                             =: \(c, b, abfun) ->
 373     let
 374         abval_rhs a = \p ->
 375            abval p                      =: \(c, b, abfun) ->
 376            (c, unit_IdEnv v (a, b, abfun))
 377         a = case rhs of
 378                 StgRhsClosure _ _ _ _ Updatable [] _ -> unit_IdEnv v 1
 379                 _                                  -> null_IdEnv
 380     in (StgNonRec v rhs', [v],  abval_rhs a, abval_rhs null_IdEnv)
 381
 382 udBinding (StgRec ve) cvs p
 383   = (StgRec ve', [], abval_rhs, abval_rhs)
 384   where
 385     (vs, ve', abvals) = unzip3 (map udBind ve)
 386     fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve
 387     vs' = mkRefs vs
 388     abval_rhs = \p ->
 389         let
 390           p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p
 391           closure = (null_IdEnv, fv', dont_know fv')
 392           fv' =  getrefs p fv vs'
 393           (cs, ps) = unzip (doRec vs abvals)
 394
 395           doRec [] _ = []
 396           doRec (v:vs) (abval:as)
 397                 = abval p'      =: \(c,b,abfun) ->
 398                   (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
 399
 400         in
 401         (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
 402
 403     udBind (v,rhs)
 404       = udRhs rhs cvs p         =: \(rhs', abval) ->
 405           (v,(v,rhs'), abval)
 406
 407     collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv
 408     collectfv (_, StgRhsCon _ con args)       = [ v | StgVarArg v <- args ]
 409 \end{code}
 410
 411 %-----------------------------------------------------------------------------
 412 \subsection{Analysing Right-Hand Sides}
 413
 414 \begin{code}
 415 udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
 416
 417 udRhs (StgRhsClosure cc bi srt fv u [] body) cvs p
 418   = ud body cvs p                       =: \(body', abval_body) ->
 419     (StgRhsClosure cc bi srt fv u [] body', abval_body)
 420 \end{code}
 421
 422 Here is the code for closures with arguments.  A closure has a number
 423 of arguments, which correspond to a set of nested lambda expressions.
 424 We build up the analysis using foldr with the function doLam to
 425 analyse each lambda expression.
 426
 427 \begin{code}
 428 udRhs (StgRhsClosure cc bi srt fv u args body) cvs p
 429   = ud body cvs p                       =: \(body', abval_body) ->
 430     let
 431         fv' = map lookup (filter (`notCaseBound` cvs) fv)
 432         abval_rhs = \p ->
 433              foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p
 434     in
 435     (StgRhsClosure cc bi srt fv u args body', abval_rhs)
 436     where
 437
 438       doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
 439       doLam i f b p
 440                 = (null_IdEnv, b,
 441                    Fun (\x@(c',b',_) ->
 442                         let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
 443                         f b'' (addOneTo_IdEnv p i x)))
 444 \end{code}
 445
 446 %-----------------------------------------------------------------------------
 447 \subsection{Adjusting Update flags}
 448
 449 The closure is tagged single entry iff it is used at most once, it is
 450 not referenced from inside a data structure or function, and it has no
 451 arguments (closures with arguments are re-entrant).
 452
 453 \begin{code}
 454 tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
 455
 456 tag b c r@(StgNonRec v (StgRhsClosure cc bi srt fv Updatable [] body))
 457   = if (v `notInRefs` b) && (lookupc c v <= 1)
 458     then -- trace "One!" (
 459            StgNonRec v (StgRhsClosure cc bi srt fv SingleEntry [] body)
 460            -- )
 461     else r
 462 tag b c other = other
 463
 464 lookupc c v = case lookup_IdEnv c v of
 465                 Just n -> n
 466                 Nothing -> 0
 467 \end{code}
 468
 469 %-----------------------------------------------------------------------------
 470 \subsection{Top Level analysis}
 471
 472 Should we tag top level closures? This could have good implications
 473 for CAFs (i.e. they could be made non-updateable if only used once,
 474 thus preventing a space leak).
 475
 476 \begin{code}
 477 updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
 478 updateAnalyse bs
 479  = udProgram bs null_IdEnv
 480
 481 udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
 482 udProgram [] p = []
 483 udProgram (d:ds) p
 484  = udBinding d noCaseBound p            =: \(d', vs, _, abval_bind) ->
 485    abval_bind p                 =: \(_, p') ->
 486    grow_IdEnv p p'                      =: \p'' ->
 487    attachUpdateInfoToBinds d' p''       =: \d'' ->
 488    d'' : udProgram ds p''
 489 \end{code}
 490
 491 %-----------------------------------------------------------------------------
 492 \subsection{Exporting Update Information}
 493
 494 Convert the exported representation of a function's update function
 495 into a real Closure value.
 496
 497 \begin{code}
 498 convertUpdateSpec :: UpdateSpec -> Closure
 499 convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs
 500
 501 mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure
 502
 503 mkClosure c b b' []       = (c, b', dont_know b')
 504 mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
 505 mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 506     mkClosure
 507             (combine_IdEnvs (+) c c')
 508             (dom_IdEnv c' `merge2` b'' `merge2` b)
 509             (b'' `merge2` b')
 510               ns ))
 511 mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 512     mkClosure c
 513             (dom_IdEnv c' `merge2` b'' `merge2` b)
 514             (dom_IdEnv c' `merge2` b'' `merge2` b')
 515               ns ))
 516 \end{code}
 517
 518 Convert a Closure into a representation that can be placed in a .hi file.
 519
 520 \begin{code}
 521 mkUpdateSpec :: Id -> Closure -> UpdateSpec
 522 mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
 523             where
 524                 (c,b,_)     = foldl doApp f ids
 525                 ids         = map mkid (getBuiltinUniques arity)
 526                 mkid u      = mkSysLocal SLIT("upd") u noType
 527                 countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
 528                 noType      = panic "UpdAnal: no type!"
 529
 530                 doApp (c,b,Fun f) i
 531                       = f (unit_IdEnv i 1, noRefs, dont_know noRefs)  =: \(c',b',f') ->
 532                           (combine_IdEnvs (+) c' c, b', f')
 533
 534                 (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
 535                 (reg_arg_tys, _)    = splitFunTys tau_ty
 536                 arity               = length dict_tys + length reg_arg_tys
 537 \end{code}
 538
 539   removeSuperfluous2s = reverse . dropWhile (> 1) . reverse
 540
 541 %-----------------------------------------------------------------------------
 542 \subsection{Attaching the update information to top-level bindings}
 543
 544 This is so that the information can later be retrieved for printing
 545 out in the .hi file.  This is not an ideal solution, however it will
 546 suffice for now.
 547
 548 \begin{code}
 549 attachUpdateInfoToBinds b p
 550   = case b of
 551         StgNonRec v rhs -> StgNonRec (attachOne v) rhs
 552         StgRec bs       -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
 553
 554   where attachOne v
 555                 | externallyVisibleId v
 556                         = let c = lookup v p in
 557                                 setIdUpdateInfo v
 558                                         (mkUpdateInfo (mkUpdateSpec v c))
 559                 | otherwise    = v
 560 \end{code}
 561
 562 %-----------------------------------------------------------------------------