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 Id               ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
  19                           unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
  20                           IdSet,
  21                           getIdUpdateInfo, addIdUpdateInfo, mkSysLocal, idType, isImportedId,
  22                           externallyVisibleId,
  23                           Id, GenId
  24                         )
  25 import IdInfo           ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
  26 import Type             ( splitFunTys, splitSigmaTy )
  27 import UniqSet
  28 import Unique           ( getBuiltinUniques )
  29 import SrcLoc           ( noSrcLoc )
  30 import Util             ( panic )
  31 \end{code}
  32
  33
  34 %-----------------------------------------------------------------------------
  35 \subsection{Reverse application}
  36
  37 This is used instead of lazy pattern bindings to avoid space leaks.
  38
  39 \begin{code}
  40 infixr 3 =:
  41 a =: k = k a
  42 \end{code}
  43
  44 %-----------------------------------------------------------------------------
  45 \subsection{Types}
  46
  47 List of closure references
  48
  49 \begin{code}
  50 type Refs = IdSet
  51 x `notInRefs` y = not (x `elementOfUniqSet` y)
  52 \end{code}
  53
  54 A closure value: environment of closures that are evaluated on entry,
  55 a list of closures that are referenced from the result, and an
  56 abstract value for the evaluated closure.
  57
  58 An IdEnv is used for the reference counts, as these environments are
  59 combined often. A generic environment is used for the main environment
  60 mapping closure names to values; as a common operation is extension of
  61 this environment, this representation should be efficient.
  62
  63 \begin{code}
  64 -- partain: funny synonyms to cope w/ the fact
  65 -- that IdEnvs know longer know what their keys are
  66 -- (94/05)  ToDo: improve
  67 type IdEnvInt       = IdEnv (Id, Int)
  68 type IdEnvClosure = IdEnv (Id, Closure)
  69
  70 -- backward-compat functions
  71 null_IdEnv :: IdEnv (Id, a)
  72 null_IdEnv = nullIdEnv
  73
  74 unit_IdEnv :: Id -> a -> IdEnv (Id, a)
  75 unit_IdEnv k v = unitIdEnv k (k, v)
  76
  77 mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
  78 mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
  79
  80 grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  81 grow_IdEnv env1 env2 = growIdEnv env1 env2
  82
  83 addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
  84 addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v)
  85
  86 combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
  87 combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2
  88   where
  89     new_combiner (id, x) (_, y) = (id, combiner x y)
  90
  91 dom_IdEnv :: IdEnv (Id, a) -> Refs
  92 dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
  93
  94 lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
  95 lookup_IdEnv env key = case lookupIdEnv env key of
  96                            Nothing    -> Nothing
  97                            Just (_,a) -> Just a
  98 -- end backward compat stuff
  99
 100 type Closure = (IdEnvInt, Refs, AbFun)
 101
 102 type AbVal = IdEnvClosure -> Closure
 103 newtype AbFun = Fun (Closure -> Closure)
 104
 105 -- partain: speeding-up stuff
 106
 107 type CaseBoundVars = IdSet
 108 noCaseBound   = emptyUniqSet
 109 isCaseBound   = elementOfUniqSet
 110 x `notCaseBound` y = not (isCaseBound x y)
 111 moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
 112 moreCaseBound old new = old `unionUniqSets` mkUniqSet new
 113
 114 -- end speeding-up
 115 \end{code}
 116
 117 %----------------------------------------------------------------------------
 118 \subsection{Environment lookup}
 119
 120 If the requested value is not in the environment, we return an unknown
 121 value.  Lookup is designed to be partially applied to a variable, and
 122 repeatedly applied to different environments after that.
 123
 124 \begin{code}
 125 lookup v
 126   | isImportedId v
 127   = const (case updateInfoMaybe (getIdUpdateInfo v) of
 128                 Nothing   -> unknownClosure
 129                 Just spec -> convertUpdateSpec spec)
 130   | otherwise
 131   = \p -> case lookup_IdEnv p v of
 132                 Just b  -> b
 133                 Nothing -> unknownClosure
 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 = mkUniqSet
 142
 143 noRefs :: Refs
 144 noRefs = emptyUniqSet
 145
 146 elemRefs = elementOfUniqSet
 147
 148 merge :: [Refs] -> Refs
 149 merge xs = foldr merge2 emptyUniqSet xs
 150
 151 merge2 :: Refs -> Refs -> Refs
 152 merge2 = unionUniqSets
 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 udAtom :: CaseBoundVars -> StgArg -> AbVal
 216 udAtom cvs (StgVarArg v)
 217         | v `isCaseBound` cvs = const unknownClosure
 218         | otherwise           = lookup v
 219
 220 udAtom cvs _                  = const noClosure
 221 \end{code}
 222
 223 %-----------------------------------------------------------------------------
 224 \subsection{Analysing an STG expression}
 225
 226 \begin{code}
 227 ud :: StgExpr                   -- Expression to be analysed
 228    -> CaseBoundVars                     -- List of case-bound vars
 229    -> IdEnvClosure                      -- Current environment
 230    -> (StgExpr, AbVal)          -- (New expression, abstract value)
 231
 232 ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
 233 ud e@(StgCon  _ vs _) cvs p = (e, udData vs cvs)
 234 ud e@(StgSCC ty lab a)   cvs p = ud a cvs p =: \(a', abval_a) ->
 235                                  (StgSCC ty 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 lvs) cvs p
 247   = (e, abval_app)
 248   where
 249     abval_atoms = map (udAtom cvs) atoms
 250     abval_a     = udAtom 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 uniq 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 uniq alts', abval_case)
 270   where
 271
 272     udAlt :: StgCaseAlts
 273           -> IdEnvClosure
 274           -> (StgCaseAlts, AbVal)
 275
 276     udAlt (StgAlgAlts ty [alt] StgNoDefault) p
 277         = udAlgAlt p alt                =: \(alt', abval) ->
 278             (StgAlgAlts ty [alt'] StgNoDefault, abval)
 279     udAlt (StgAlgAlts ty [] def) p
 280         = udDef def p                   =: \(def', abval) ->
 281           (StgAlgAlts ty [] def', abval)
 282     udAlt (StgAlgAlts ty alts def) p
 283         = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p
 284     udAlt (StgPrimAlts ty [alt] StgNoDefault) p
 285         = udPrimAlt p alt               =: \(alt', abval) ->
 286           (StgPrimAlts ty [alt'] StgNoDefault, abval)
 287     udAlt (StgPrimAlts ty [] def) p
 288         = udDef def p                   =: \(def', abval) ->
 289           (StgPrimAlts ty [] def', abval)
 290     udAlt (StgPrimAlts ty alts def) p
 291         = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
 292
 293     udPrimAlt p (l, e)
 294       = ud e cvs p              =: \(e', v) -> ((l, e'), v)
 295
 296     udAlgAlt p (id, vs, use_mask, e)
 297       = ud e (moreCaseBound cvs vs) p   =: \(e', v) -> ((id, vs, use_mask, e'), v)
 298
 299     udDef :: StgCaseDefault
 300           -> IdEnvClosure
 301           -> (StgCaseDefault, AbVal)
 302
 303     udDef StgNoDefault p
 304       = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
 305     udDef (StgBindDefault v is_used expr) p
 306       = ud expr (moreCaseBound cvs [v]) p       =: \(expr', abval) ->
 307           (StgBindDefault v is_used expr', abval)
 308
 309     udManyAlts alts def udalt stgalts p
 310         = udDef def p                           =: \(def', abval_def) ->
 311           unzip (map (udalt p) alts)            =: \(alts', abvals_alts) ->
 312           let
 313                 abval_alts = \p ->
 314                   abval_def p                    =: \(cd, bd, _) ->
 315                   unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) ->
 316                   let bs' = merge (bd:bs) in
 317                   (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs')
 318           in (stgalts alts' def', abval_alts)
 319 \end{code}
 320
 321 The heart of the analysis: here we decide whether to make a specific
 322 closure updatable or not, based on the results of analysing the body.
 323
 324 \begin{code}
 325 ud (StgLet binds body) cvs p
 326  = udBinding binds cvs p                =: \(binds', vs, abval1, abval2) ->
 327    abval1 p                             =: \(cs, p') ->
 328    grow_IdEnv p p'                      =: \p ->
 329    ud body cvs p                        =: \(body', abval_body) ->
 330    abval_body   p                       =: \(c, b, abfun) ->
 331    tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
 332    let
 333       abval p
 334           = abval2 p                            =: \(c1, p')       ->
 335             abval_body (grow_IdEnv p p')        =: \(c2, b, abfun) ->
 336             (combine_IdEnvs (+) c1 c2, b, abfun)
 337    in
 338    (StgLet tagged_binds body', abval)
 339 \end{code}
 340
 341 %-----------------------------------------------------------------------------
 342 \subsection{Analysing bindings}
 343
 344 For recursive sets of bindings we perform one iteration of a fixed
 345 point algorithm, using (dont_know fv) as a safe approximation to the
 346 real fixed point, where fv are the (mappings in the environment of
 347 the) free variables of the function.
 348
 349 We'll return two new environments, one with the new closures in and
 350 one without. There's no point in carrying around closures when their
 351 respective bindings have already been analysed.
 352
 353 We don't need to find anything out about closures with arguments,
 354 constructor closures etc.
 355
 356 \begin{code}
 357 udBinding :: StgBinding
 358             -> CaseBoundVars
 359           -> IdEnvClosure
 360             -> (StgBinding,
 361                 [Id],
 362                 IdEnvClosure -> (IdEnvInt, IdEnvClosure),
 363                 IdEnvClosure -> (IdEnvInt, IdEnvClosure))
 364
 365 udBinding (StgNonRec v rhs) cvs p
 366   = udRhs rhs cvs p                     =: \(rhs', abval) ->
 367     abval p                             =: \(c, b, abfun) ->
 368     let
 369         abval_rhs a = \p ->
 370            abval p                      =: \(c, b, abfun) ->
 371            (c, unit_IdEnv v (a, b, abfun))
 372         a = case rhs of
 373                 StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1
 374                 _                                  -> null_IdEnv
 375     in (StgNonRec v rhs', [v],  abval_rhs a, abval_rhs null_IdEnv)
 376
 377 udBinding (StgRec ve) cvs p
 378   = (StgRec ve', [], abval_rhs, abval_rhs)
 379   where
 380     (vs, ve', abvals) = unzip3 (map udBind ve)
 381     fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve
 382     vs' = mkRefs vs
 383     abval_rhs = \p ->
 384         let
 385           p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p
 386           closure = (null_IdEnv, fv', dont_know fv')
 387           fv' =  getrefs p fv vs'
 388           (cs, ps) = unzip (doRec vs abvals)
 389
 390           doRec [] _ = []
 391           doRec (v:vs) (abval:as)
 392                 = abval p'      =: \(c,b,abfun) ->
 393                   (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
 394
 395         in
 396         (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
 397
 398     udBind (v,rhs)
 399       = udRhs rhs cvs p         =: \(rhs', abval) ->
 400           (v,(v,rhs'), abval)
 401
 402     collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
 403     collectfv (_, StgRhsCon _ con args)       = [ v | (StgVarArg v) <- args ]
 404 \end{code}
 405
 406 %-----------------------------------------------------------------------------
 407 \subsection{Analysing Right-Hand Sides}
 408
 409 \begin{code}
 410 udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
 411
 412 udRhs (StgRhsClosure cc bi fv u [] body) cvs p
 413   = ud body cvs p                       =: \(body', abval_body) ->
 414     (StgRhsClosure cc bi fv u [] body', abval_body)
 415 \end{code}
 416
 417 Here is the code for closures with arguments.  A closure has a number
 418 of arguments, which correspond to a set of nested lambda expressions.
 419 We build up the analysis using foldr with the function doLam to
 420 analyse each lambda expression.
 421
 422 \begin{code}
 423 udRhs (StgRhsClosure cc bi fv u args body) cvs p
 424   = ud body cvs p                       =: \(body', abval_body) ->
 425     let
 426         fv' = map lookup (filter (`notCaseBound` cvs) fv)
 427         abval_rhs = \p ->
 428              foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p
 429     in
 430     (StgRhsClosure cc bi fv u args body', abval_rhs)
 431     where
 432
 433       doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
 434       doLam i f b p
 435                 = (null_IdEnv, b,
 436                    Fun (\x@(c',b',_) ->
 437                         let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
 438                         f b'' (addOneTo_IdEnv p i x)))
 439 \end{code}
 440
 441 %-----------------------------------------------------------------------------
 442 \subsection{Adjusting Update flags}
 443
 444 The closure is tagged single entry iff it is used at most once, it is
 445 not referenced from inside a data structure or function, and it has no
 446 arguments (closures with arguments are re-entrant).
 447
 448 \begin{code}
 449 tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
 450
 451 tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
 452   = if (v `notInRefs` b) && (lookupc c v <= 1)
 453     then -- trace "One!" (
 454            StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
 455            -- )
 456     else r
 457 tag b c other = other
 458
 459 lookupc c v = case lookup_IdEnv c v of
 460                 Just n -> n
 461                 Nothing -> 0
 462 \end{code}
 463
 464 %-----------------------------------------------------------------------------
 465 \subsection{Top Level analysis}
 466
 467 Should we tag top level closures? This could have good implications
 468 for CAFs (i.e. they could be made non-updateable if only used once,
 469 thus preventing a space leak).
 470
 471 \begin{code}
 472 updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
 473 updateAnalyse bs
 474  = udProgram bs null_IdEnv
 475
 476 udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
 477 udProgram [] p = []
 478 udProgram (d:ds) p
 479  = udBinding d noCaseBound p            =: \(d', vs, _, abval_bind) ->
 480    abval_bind p                 =: \(_, p') ->
 481    grow_IdEnv p p'                      =: \p'' ->
 482    attachUpdateInfoToBinds d' p''       =: \d'' ->
 483    d'' : udProgram ds p''
 484 \end{code}
 485
 486 %-----------------------------------------------------------------------------
 487 \subsection{Exporting Update Information}
 488
 489 Convert the exported representation of a function's update function
 490 into a real Closure value.
 491
 492 \begin{code}
 493 convertUpdateSpec :: UpdateSpec -> Closure
 494 convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs
 495
 496 mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure
 497
 498 mkClosure c b b' []       = (c, b', dont_know b')
 499 mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
 500 mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 501     mkClosure
 502             (combine_IdEnvs (+) c c')
 503             (dom_IdEnv c' `merge2` b'' `merge2` b)
 504             (b'' `merge2` b')
 505               ns ))
 506 mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
 507     mkClosure c
 508             (dom_IdEnv c' `merge2` b'' `merge2` b)
 509             (dom_IdEnv c' `merge2` b'' `merge2` b')
 510               ns ))
 511 \end{code}
 512
 513 Convert a Closure into a representation that can be placed in a .hi file.
 514
 515 \begin{code}
 516 mkUpdateSpec :: Id -> Closure -> UpdateSpec
 517 mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
 518             where
 519                 (c,b,_)     = foldl doApp f ids
 520                 ids         = map mkid (getBuiltinUniques arity)
 521                 mkid u      = mkSysLocal SLIT("upd") u noType noSrcLoc
 522                 countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
 523                 noType      = panic "UpdAnal: no type!"
 524
 525                 doApp (c,b,Fun f) i
 526                       = f (unit_IdEnv i 1, noRefs, dont_know noRefs)  =: \(c',b',f') ->
 527                           (combine_IdEnvs (+) c' c, b', f')
 528
 529                 (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
 530                 (reg_arg_tys, _)    = splitFunTys tau_ty
 531                 arity               = length dict_tys + length reg_arg_tys
 532 \end{code}
 533
 534   removeSuperfluous2s = reverse . dropWhile (> 1) . reverse
 535
 536 %-----------------------------------------------------------------------------
 537 \subsection{Attaching the update information to top-level bindings}
 538
 539 This is so that the information can later be retrieved for printing
 540 out in the .hi file.  This is not an ideal solution, however it will
 541 suffice for now.
 542
 543 \begin{code}
 544 attachUpdateInfoToBinds b p
 545   = case b of
 546         StgNonRec v rhs -> StgNonRec (attachOne v) rhs
 547         StgRec bs       -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
 548
 549   where attachOne v
 550                 | externallyVisibleId v
 551                         = let c = lookup v p in
 552                                 addIdUpdateInfo v
 553                                         (mkUpdateInfo (mkUpdateSpec v c))
 554                 | otherwise    = v
 555 \end{code}
 556
 557 %-----------------------------------------------------------------------------