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