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-1996
   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 MkId             ( mkSysLocal )
  19 import Id               ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
  20                           unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
  21                           IdSet,
  22                           getIdUpdateInfo, addIdUpdateInfo, idType,
  23                           externallyVisibleId,
  24                           Id
  25                         )
  26 import IdInfo           ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
  27 import Name             ( isLocallyDefined )
  28 import Type             ( splitFunTys, splitSigmaTy )
  29 import UniqSet
  30 import Unique           ( getBuiltinUniques )
  31 import SrcLoc           ( noSrcLoc )
  32 import Util             ( panic )
  33 \end{code}
  34
  35
  36 %-----------------------------------------------------------------------------
  37 \subsection{Reverse application}
  38
  39 This is used instead of lazy pattern bindings to avoid space leaks.
  40
  41 \begin{code}
  42 infixr 3 =:
  43 a =: k = k a
  44 \end{code}
  45
  46 %-----------------------------------------------------------------------------
  47 \subsection{Types}
  48
  49 List of closure references
  50
  51 \begin{code}
  52 type Refs = IdSet
  53 x `notInRefs` y = not (x `elementOfUniqSet` y)
  54 \end{code}
  55
  56 A closure value: environment of closures that are evaluated on entry,
  57 a list of closures that are referenced from the result, and an
  58 abstract value for the evaluated closure.
  59
  60 An IdEnv is used for the reference counts, as these environments are
  61 combined often. A generic environment is used for the main environment
  62 mapping closure names to values; as a common operation is extension of
  63 this environment, this representation should be efficient.
  64
  65 \begin{code}
  66 -- partain: funny synonyms to cope w/ the fact
  67 -- that IdEnvs know longer know what their keys are
  68 -- (94/05)  ToDo: improve
  69 type IdEnvInt       = IdEnv (Id, Int)
  70 type IdEnvClosure = IdEnv (Id, Closure)
  71
  72 -- backward-compat functions
  73 null_IdEnv :: IdEnv (Id, a)
  74 null_IdEnv = nullIdEnv
  75
  76 unit_IdEnv :: Id -> a -> IdEnv (Id, a)
  77 unit_IdEnv k v = unitIdEnv k (k, v)
  78
  79 mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
  80 mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
  81
  82 grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  83 grow_IdEnv env1 env2 = growIdEnv env1 env2
  84
  85 addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
  86 addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v)
  87
  88 combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  89 combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2
  90   where
  91     new_combiner (id, x) (_, y) = (id, combiner x y)
  92
  93 dom_IdEnv :: IdEnv (Id, a) -> Refs
  94 dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
  95
  96 lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
  97 lookup_IdEnv env key = case lookupIdEnv env key of
  98                            Nothing    -> Nothing
  99                            Just (_,a) -> Just a
 100 -- end backward compat stuff
 101
 102 type Closure = (IdEnvInt, Refs, AbFun)
 103
 104 type AbVal = IdEnvClosure -> Closure
 105 newtype AbFun = Fun (Closure -> Closure)
 106
 107 -- partain: speeding-up stuff
 108
 109 type CaseBoundVars = IdSet
 110 noCaseBound   = emptyUniqSet
 111 isCaseBound   = elementOfUniqSet
 112 x `notCaseBound` y = not (isCaseBound x y)
 113 moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
 114 moreCaseBound old new = old `unionUniqSets` mkUniqSet new
 115
 116 -- end speeding-up
 117 \end{code}
 118
 119 %----------------------------------------------------------------------------
 120 \subsection{Environment lookup}
 121
 122 If the requested value is not in the environment, we return an unknown
 123 value.  Lookup is designed to be partially applied to a variable, and
 124 repeatedly applied to different environments after that.
 125
 126 \begin{code}
 127 lookup v
 128   | isLocallyDefined v
 129   = \p -> case lookup_IdEnv p v of
 130                 Just b  -> b
 131                 Nothing -> unknownClosure
 132
 133   | otherwise
 134   = const (case updateInfoMaybe (getIdUpdateInfo v) of
 135                 Nothing   -> unknownClosure
 136                 Just spec -> convertUpdateSpec spec)
 137 \end{code}
 138
 139 %-----------------------------------------------------------------------------
 140 Represent a list of references as an ordered list.
 141
 142 \begin{code}
 143 mkRefs :: [Id] -> Refs
 144 mkRefs = mkUniqSet
 145
 146 noRefs :: Refs
 147 noRefs = emptyUniqSet
 148
 149 elemRefs = elementOfUniqSet
 150
 151 merge :: [Refs] -> Refs
 152 merge xs = foldr merge2 emptyUniqSet xs
 153
 154 merge2 :: Refs -> Refs -> Refs
 155 merge2 = unionUniqSets
 156 \end{code}
 157
 158 %-----------------------------------------------------------------------------
 159 \subsection{Some non-interesting values}
 160
 161 bottom will be used for abstract values that are not functions.
 162 Hopefully its value will never be required!
 163
 164 \begin{code}
 165 bottom          :: AbFun
 166 bottom          = panic "Internal: (Update Analyser) bottom"
 167 \end{code}
 168
 169 noClosure is a value that is definitely not a function (i.e. primitive
 170 values and constructor applications).  unknownClosure is a value about
 171 which we have no information at all.  This should occur rarely, but
 172 could happen when an id is imported and the exporting module was not
 173 compiled with the update analyser.
 174
 175 \begin{code}
 176 noClosure, unknownClosure :: Closure
 177 noClosure               = (null_IdEnv, noRefs, bottom)
 178 unknownClosure  = (null_IdEnv, noRefs, dont_know noRefs)
 179 \end{code}
 180
 181 dont_know is a black hole: it is something we know nothing about.
 182 Applying dont_know to anything will generate a new dont_know that simply
 183 contains more buried references.
 184
 185 \begin{code}
 186 dont_know :: Refs -> AbFun
 187 dont_know b'
 188         = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b'
 189                          in (null_IdEnv, b'', dont_know b''))
 190 \end{code}
 191
 192 -----------------------------------------------------------------------------
 193
 194 \begin{code}
 195 getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs
 196 getrefs p vs rest = foldr merge2 rest  (getrefs' (map ($ p) vs))
 197         where
 198                 getrefs' []           = []
 199                 getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs
 200 \end{code}
 201
 202 -----------------------------------------------------------------------------
 203
 204 udData is used when we are putting a list of closure references into a
 205 data structure, or something else that we know nothing about.
 206
 207 \begin{code}
 208 udData :: [StgArg] -> CaseBoundVars -> AbVal
 209 udData vs cvs
 210         = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
 211         where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ]
 212 \end{code}
 213
 214 %-----------------------------------------------------------------------------
 215 \subsection{Analysing an atom}
 216
 217 \begin{code}
 218 udAtom :: CaseBoundVars -> StgArg -> AbVal
 219 udAtom cvs (StgVarArg v)
 220         | v `isCaseBound` cvs = const unknownClosure
 221         | otherwise           = lookup v
 222
 223 udAtom cvs _                  = const noClosure
 224 \end{code}
 225
 226 %-----------------------------------------------------------------------------
 227 \subsection{Analysing an STG expression}
 228
 229 \begin{code}
 230 ud :: StgExpr                   -- Expression to be analysed
 231    -> CaseBoundVars                     -- List of case-bound vars
 232    -> IdEnvClosure                      -- Current environment
 233    -> (StgExpr, AbVal)          -- (New expression, abstract value)
 234
 235 ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
 236 ud e@(StgCon  _ vs _) cvs p = (e, udData vs cvs)
 237 ud e@(StgSCC ty lab a)   cvs p = ud a cvs p =: \(a', abval_a) ->
 238                                  (StgSCC ty lab a', abval_a)
 239 \end{code}
 240
 241 Here is application. The first thing to do is analyse the head, and
 242 get an abstract function. Multiple applications are performed by using
 243 a foldl with the function doApp. Closures are actually passed to the
 244 abstract function iff the atom is a local variable.
 245
 246 I've left the type signature for doApp in to make things a bit clearer.
 247
 248 \begin{code}
 249 ud e@(StgApp a atoms lvs) cvs p
 250   = (e, abval_app)
 251   where
 252     abval_atoms = map (udAtom cvs) atoms
 253     abval_a     = udAtom cvs a
 254     abval_app = \p ->
 255         let doApp :: Closure -> AbVal -> Closure
 256             doApp (c, b, Fun f) abval_atom =
 257                   abval_atom p          =: \e@(_,_,_)    ->
 258                   f e                   =: \(c', b', f') ->
 259                   (combine_IdEnvs (+) c' c, b', f')
 260         in foldl doApp (abval_a p) abval_atoms
 261
 262 ud (StgCase expr lve lva uniq alts) cvs p
 263   = ud expr cvs p                       =: \(expr', abval_selector)  ->
 264     udAlt alts p                        =: \(alts', abval_alts) ->
 265     let
 266         abval_case = \p ->
 267           abval_selector p              =: \(c, b, abfun_selector) ->
 268           abval_alts p                  =: \(cs, bs, abfun_alts)   ->
 269           let bs' = b `merge2` bs in
 270           (combine_IdEnvs (+) c cs, bs', dont_know bs')
 271     in
 272     (StgCase expr' lve lva uniq alts', abval_case)
 273   where
 274
 275     udAlt :: StgCaseAlts
 276           -> IdEnvClosure
 277           -> (StgCaseAlts, AbVal)
 278
 279     udAlt (StgAlgAlts ty [alt] StgNoDefault) p
 280         = udAlgAlt p alt                =: \(alt', abval) ->
 281             (StgAlgAlts ty [alt'] StgNoDefault, abval)
 282     udAlt (StgAlgAlts ty [] def) p
 283         = udDef def p                   =: \(def', abval) ->
 284           (StgAlgAlts ty [] def', abval)
 285     udAlt (StgAlgAlts ty alts def) p
 286         = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p
 287     udAlt (StgPrimAlts ty [alt] StgNoDefault) p
 288         = udPrimAlt p alt               =: \(alt', abval) ->
 289           (StgPrimAlts ty [alt'] StgNoDefault, abval)
 290     udAlt (StgPrimAlts ty [] def) p
 291         = udDef def p                   =: \(def', abval) ->
 292           (StgPrimAlts ty [] def', abval)
 293     udAlt (StgPrimAlts ty alts def) p
 294         = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
 295
 296     udPrimAlt p (l, e)
 297       = ud e cvs p              =: \(e', v) -> ((l, e'), v)
 298
 299     udAlgAlt p (id, vs, use_mask, e)
 300       = ud e (moreCaseBound cvs vs) p   =: \(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 v is_used expr) p
 309       = ud expr (moreCaseBound cvs [v]) p       =: \(expr', abval) ->
 310           (StgBindDefault v is_used 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 fv u [] body) cvs p
 416   = ud body cvs p                       =: \(body', abval_body) ->
 417     (StgRhsClosure cc bi 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 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 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 fv Updatable [] body))
 455   = if (v `notInRefs` b) && (lookupc c v <= 1)
 456     then -- trace "One!" (
 457            StgNonRec v (StgRhsClosure cc bi 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 SLIT("upd") u noType noSrcLoc
 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                                 addIdUpdateInfo v
 556                                         (mkUpdateInfo (mkUpdateSpec v c))
 557                 | otherwise    = v
 558 \end{code}
 559
 560 %-----------------------------------------------------------------------------