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