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                           getIdUpdateInfo, 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 Util             ( 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 (getIdUpdateInfo 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@(StgCon  _ vs _) cvs p = (e, udData vs cvs)
 234 ud e@(StgSCC lab a)  cvs p = ud a cvs p =: \(a', abval_a) ->
 235                                  (StgSCC lab a', abval_a)
 236 \end{code}
 237
 238 Here is application. The first thing to do is analyse the head, and
 239 get an abstract function. Multiple applications are performed by using
 240 a foldl with the function doApp. Closures are actually passed to the
 241 abstract function iff the atom is a local variable.
 242
 243 I've left the type signature for doApp in to make things a bit clearer.
 244
 245 \begin{code}
 246 ud e@(StgApp a atoms) cvs p
 247   = (e, abval_app)
 248   where
 249     abval_atoms = map (udAtom cvs) atoms
 250     abval_a     = udVar cvs a
 251     abval_app = \p ->
 252         let doApp :: Closure -> AbVal -> Closure
 253             doApp (c, b, Fun f) abval_atom =
 254                   abval_atom p          =: \e@(_,_,_)    ->
 255                   f e                   =: \(c', b', f') ->
 256                   (combine_IdEnvs (+) c' c, b', f')
 257         in foldl doApp (abval_a p) abval_atoms
 258
 259 ud (StgCase expr lve lva bndr srt alts) cvs p
 260   = ud expr cvs p                       =: \(expr', abval_selector)  ->
 261     udAlt alts p                        =: \(alts', abval_alts) ->
 262     let
 263         abval_case = \p ->
 264           abval_selector p              =: \(c, b, abfun_selector) ->
 265           abval_alts p                  =: \(cs, bs, abfun_alts)   ->
 266           let bs' = b `merge2` bs in
 267           (combine_IdEnvs (+) c cs, bs', dont_know bs')
 268     in
 269     (StgCase expr' lve lva bndr srt alts', abval_case)
 270   where
 271
 272     alts_cvs = moreCaseBound cvs [bndr]
 273
 274     udAlt :: StgCaseAlts
 275           -> IdEnvClosure
 276           -> (StgCaseAlts, AbVal)
 277
 278     udAlt (StgAlgAlts ty [alt] StgNoDefault) p
 279         = udAlgAlt p alt                =: \(alt', abval) ->
 280             (StgAlgAlts ty [alt'] StgNoDefault, abval)
 281     udAlt (StgAlgAlts ty [] def) p
 282         = udDef def p                   =: \(def', abval) ->
 283           (StgAlgAlts ty [] def', abval)
 284     udAlt (StgAlgAlts ty alts def) p
 285         = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p
 286     udAlt (StgPrimAlts ty [alt] StgNoDefault) p
 287         = udPrimAlt p alt               =: \(alt', abval) ->
 288           (StgPrimAlts ty [alt'] StgNoDefault, abval)
 289     udAlt (StgPrimAlts ty [] def) p
 290         = udDef def p                   =: \(def', abval) ->
 291           (StgPrimAlts ty [] def', abval)
 292     udAlt (StgPrimAlts ty alts def) p
 293         = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
 294
 295     udPrimAlt p (l, e)
 296       = ud e alts_cvs p         =: \(e', v) -> ((l, e'), v)
 297
 298     udAlgAlt p (id, vs, use_mask, e)
 299       = ud e (moreCaseBound alts_cvs vs) p
 300                                 =: \(e', v) -> ((id, vs, use_mask, e'), v)
 301
 302     udDef :: StgCaseDefault
 303           -> IdEnvClosure
 304           -> (StgCaseDefault, AbVal)
 305
 306     udDef StgNoDefault p
 307       = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
 308     udDef (StgBindDefault expr) p
 309       = ud expr alts_cvs p      =: \(expr', abval) ->
 310           (StgBindDefault expr', abval)
 311
 312     udManyAlts alts def udalt stgalts p
 313         = udDef def p                           =: \(def', abval_def) ->
 314           unzip (map (udalt p) alts)            =: \(alts', abvals_alts) ->
 315           let
 316                 abval_alts = \p ->
 317                   abval_def p                    =: \(cd, bd, _) ->
 318                   unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) ->
 319                   let bs' = merge (bd:bs) in
 320                   (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs')
 321           in (stgalts alts' def', abval_alts)
 322 \end{code}
 323
 324 The heart of the analysis: here we decide whether to make a specific
 325 closure updatable or not, based on the results of analysing the body.
 326
 327 \begin{code}
 328 ud (StgLet binds body) cvs p
 329  = udBinding binds cvs p                =: \(binds', vs, abval1, abval2) ->
 330    abval1 p                             =: \(cs, p') ->
 331    grow_IdEnv p p'                      =: \p ->
 332    ud body cvs p                        =: \(body', abval_body) ->
 333    abval_body   p                       =: \(c, b, abfun) ->
 334    tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
 335    let
 336       abval p
 337           = abval2 p                            =: \(c1, p')       ->
 338             abval_body (grow_IdEnv p p')        =: \(c2, b, abfun) ->
 339             (combine_IdEnvs (+) c1 c2, b, abfun)
 340    in
 341    (StgLet tagged_binds body', abval)
 342 \end{code}
 343
 344 %-----------------------------------------------------------------------------
 345 \subsection{Analysing bindings}
 346
 347 For recursive sets of bindings we perform one iteration of a fixed
 348 point algorithm, using (dont_know fv) as a safe approximation to the
 349 real fixed point, where fv are the (mappings in the environment of
 350 the) free variables of the function.
 351
 352 We'll return two new environments, one with the new closures in and
 353 one without. There's no point in carrying around closures when their
 354 respective bindings have already been analysed.
 355
 356 We don't need to find anything out about closures with arguments,
 357 constructor closures etc.
 358
 359 \begin{code}
 360 udBinding :: StgBinding
 361             -> CaseBoundVars
 362           -> IdEnvClosure
 363             -> (StgBinding,
 364                 [Id],
 365                 IdEnvClosure -> (IdEnvInt, IdEnvClosure),
 366                 IdEnvClosure -> (IdEnvInt, IdEnvClosure))
 367
 368 udBinding (StgNonRec v rhs) cvs p
 369   = udRhs rhs cvs p                     =: \(rhs', abval) ->
 370     abval p                             =: \(c, b, abfun) ->
 371     let
 372         abval_rhs a = \p ->
 373            abval p                      =: \(c, b, abfun) ->
 374            (c, unit_IdEnv v (a, b, abfun))
 375         a = case rhs of
 376                 StgRhsClosure _ _ _ _ Updatable [] _ -> unit_IdEnv v 1
 377                 _                                  -> null_IdEnv
 378     in (StgNonRec v rhs', [v],  abval_rhs a, abval_rhs null_IdEnv)
 379
 380 udBinding (StgRec ve) cvs p
 381   = (StgRec ve', [], abval_rhs, abval_rhs)
 382   where
 383     (vs, ve', abvals) = unzip3 (map udBind ve)
 384     fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve
 385     vs' = mkRefs vs
 386     abval_rhs = \p ->
 387         let
 388           p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p
 389           closure = (null_IdEnv, fv', dont_know fv')
 390           fv' =  getrefs p fv vs'
 391           (cs, ps) = unzip (doRec vs abvals)
 392
 393           doRec [] _ = []
 394           doRec (v:vs) (abval:as)
 395                 = abval p'      =: \(c,b,abfun) ->
 396                   (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
 397
 398         in
 399         (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
 400
 401     udBind (v,rhs)
 402       = udRhs rhs cvs p         =: \(rhs', abval) ->
 403           (v,(v,rhs'), abval)
 404
 405     collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv
 406     collectfv (_, StgRhsCon _ con args)       = [ v | (StgVarArg v) <- args ]
 407 \end{code}
 408
 409 %-----------------------------------------------------------------------------
 410 \subsection{Analysing Right-Hand Sides}
 411
 412 \begin{code}
 413 udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
 414
 415 udRhs (StgRhsClosure cc bi srt fv u [] body) cvs p
 416   = ud body cvs p                       =: \(body', abval_body) ->
 417     (StgRhsClosure cc bi srt fv u [] body', abval_body)
 418 \end{code}
 419
 420 Here is the code for closures with arguments.  A closure has a number
 421 of arguments, which correspond to a set of nested lambda expressions.
 422 We build up the analysis using foldr with the function doLam to
 423 analyse each lambda expression.
 424
 425 \begin{code}
 426 udRhs (StgRhsClosure cc bi srt fv u args body) cvs p
 427   = ud body cvs p                       =: \(body', abval_body) ->
 428     let
 429         fv' = map lookup (filter (`notCaseBound` cvs) fv)
 430         abval_rhs = \p ->
 431              foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p
 432     in
 433     (StgRhsClosure cc bi srt fv u args body', abval_rhs)
 434     where
 435
 436       doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
 437       doLam i f b p
 438                 = (null_IdEnv, b,
 439                    Fun (\x@(c',b',_) ->
 440                         let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
 441                         f b'' (addOneTo_IdEnv p i x)))
 442 \end{code}
 443
 444 %-----------------------------------------------------------------------------
 445 \subsection{Adjusting Update flags}
 446
 447 The closure is tagged single entry iff it is used at most once, it is
 448 not referenced from inside a data structure or function, and it has no
 449 arguments (closures with arguments are re-entrant).
 450
 451 \begin{code}
 452 tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
 453
 454 tag b c r@(StgNonRec v (StgRhsClosure cc bi srt fv Updatable [] body))
 455   = if (v `notInRefs` b) && (lookupc c v <= 1)
 456     then -- trace "One!" (
 457            StgNonRec v (StgRhsClosure cc bi srt fv SingleEntry [] body)
 458            -- )
 459     else r
 460 tag b c other = other
 461
 462 lookupc c v = case lookup_IdEnv c v of
 463                 Just n -> n
 464                 Nothing -> 0
 465 \end{code}
 466
 467 %-----------------------------------------------------------------------------
 468 \subsection{Top Level analysis}
 469
 470 Should we tag top level closures? This could have good implications
 471 for CAFs (i.e. they could be made non-updateable if only used once,
 472 thus preventing a space leak).
 473
 474 \begin{code}
 475 updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
 476 updateAnalyse bs
 477  = udProgram bs null_IdEnv
 478
 479 udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
 480 udProgram [] p = []
 481 udProgram (d:ds) p
 482  = udBinding d noCaseBound p            =: \(d', vs, _, abval_bind) ->
 483    abval_bind p                 =: \(_, p') ->
 484    grow_IdEnv p p'                      =: \p'' ->
 485    attachUpdateInfoToBinds d' p''       =: \d'' ->
 486    d'' : udProgram ds p''
 487 \end{code}
 488
 489 %-----------------------------------------------------------------------------
 490 \subsection{Exporting Update Information}
 491
 492 Convert the exported representation of a function's update function
 493 into a real Closure value.
 494
 495 \begin{code}
 496 convertUpdateSpec :: UpdateSpec -> Closure
 497 convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs
 498
 499 mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure
 500
 501 mkClosure c b b' []       = (c, b', dont_know b')
 502 mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
 503 mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 504     mkClosure
 505             (combine_IdEnvs (+) c c')
 506             (dom_IdEnv c' `merge2` b'' `merge2` b)
 507             (b'' `merge2` b')
 508               ns ))
 509 mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 510     mkClosure c
 511             (dom_IdEnv c' `merge2` b'' `merge2` b)
 512             (dom_IdEnv c' `merge2` b'' `merge2` b')
 513               ns ))
 514 \end{code}
 515
 516 Convert a Closure into a representation that can be placed in a .hi file.
 517
 518 \begin{code}
 519 mkUpdateSpec :: Id -> Closure -> UpdateSpec
 520 mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
 521             where
 522                 (c,b,_)     = foldl doApp f ids
 523                 ids         = map mkid (getBuiltinUniques arity)
 524                 mkid u      = mkSysLocal u noType
 525                 countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
 526                 noType      = panic "UpdAnal: no type!"
 527
 528                 doApp (c,b,Fun f) i
 529                       = f (unit_IdEnv i 1, noRefs, dont_know noRefs)  =: \(c',b',f') ->
 530                           (combine_IdEnvs (+) c' c, b', f')
 531
 532                 (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
 533                 (reg_arg_tys, _)    = splitFunTys tau_ty
 534                 arity               = length dict_tys + length reg_arg_tys
 535 \end{code}
 536
 537   removeSuperfluous2s = reverse . dropWhile (> 1) . reverse
 538
 539 %-----------------------------------------------------------------------------
 540 \subsection{Attaching the update information to top-level bindings}
 541
 542 This is so that the information can later be retrieved for printing
 543 out in the .hi file.  This is not an ideal solution, however it will
 544 suffice for now.
 545
 546 \begin{code}
 547 attachUpdateInfoToBinds b p
 548   = case b of
 549         StgNonRec v rhs -> StgNonRec (attachOne v) rhs
 550         StgRec bs       -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
 551
 552   where attachOne v
 553                 | externallyVisibleId v
 554                         = let c = lookup v p in
 555                                 setIdUpdateInfo v
 556                                         (mkUpdateInfo (mkUpdateSpec v c))
 557                 | otherwise    = v
 558 \end{code}
 559
 560 %-----------------------------------------------------------------------------