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