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