ghc/compiler/simplStg/UpdAnal.lhs

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