tools.destructors: destructors. and leaks words now output a 'show instances' link which lists all relevant disposables
parent
3be328056d
commit
b12bbaf7ec
basis/tools/destructors
core/destructors
|
@ -1,31 +1,51 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes destructors fry kernel math namespaces
|
||||
prettyprint sequences sets sorting ;
|
||||
prettyprint sequences sets sorting continuations accessors arrays
|
||||
io io.styles combinators.smart ;
|
||||
IN: tools.destructors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: disposable-tally ( -- assoc )
|
||||
disposables get
|
||||
H{ } clone [ [ keys ] dip '[ class _ inc-at ] each ] keep ;
|
||||
|
||||
: subtract-values ( assoc1 assoc2 -- assoc )
|
||||
[ [ keys ] bi@ append prune ] 2keep
|
||||
H{ } clone [
|
||||
'[
|
||||
[ _ _ [ at 0 or ] bi-curry@ bi - ] keep _ set-at
|
||||
] each
|
||||
] keep ;
|
||||
: class-tally ( assoc -- assoc' )
|
||||
H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ;
|
||||
|
||||
: (disposables.) ( assoc -- )
|
||||
>alist sort-keys simple-table. ;
|
||||
class-tally >alist [ first2 [ length ] keep 3array ] map [ second ] sort-with
|
||||
standard-table-style [
|
||||
[
|
||||
[ "Disposable class" write ] with-cell
|
||||
[ "Instances" write ] with-cell
|
||||
[ ] with-cell
|
||||
] with-row
|
||||
[
|
||||
[
|
||||
[
|
||||
[ pprint-cell ]
|
||||
[ pprint-cell ]
|
||||
[ [ "[ List instances ]" swap write-object ] with-cell ]
|
||||
tri*
|
||||
] input<sequence
|
||||
] with-row
|
||||
] each
|
||||
] tabular-output nl ;
|
||||
|
||||
: sort-disposables ( seq -- seq' )
|
||||
[ disposable? ] partition [ [ id>> ] sort-with ] dip append ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: disposables. ( -- )
|
||||
disposable-tally (disposables.) ;
|
||||
disposables get (disposables.) ;
|
||||
|
||||
: disposables-of-class. ( class -- )
|
||||
[ disposables get values sort-disposables ] dip
|
||||
'[ _ instance? ] filter stack. ;
|
||||
|
||||
: leaks ( quot -- )
|
||||
disposable-tally [ call disposable-tally ] dip subtract-values
|
||||
(disposables.) ; inline
|
||||
disposables get clone
|
||||
debug-leaks? on
|
||||
[
|
||||
[ call disposables get clone ] dip
|
||||
] [ ] [ debug-leaks? off ] cleanup
|
||||
assoc-diff (disposables.) ; inline
|
||||
|
|
|
@ -1,24 +1,34 @@
|
|||
! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors continuations kernel namespaces make
|
||||
sequences vectors sets assocs init ;
|
||||
sequences vectors sets assocs init math ;
|
||||
IN: destructors
|
||||
|
||||
SYMBOL: disposables
|
||||
|
||||
[ H{ } clone disposables set-global ] "destructors" add-init-hook
|
||||
|
||||
ERROR: already-unregistered disposable ;
|
||||
|
||||
SYMBOL: debug-leaks?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SLOT: continuation
|
||||
|
||||
: register-disposable ( obj -- )
|
||||
debug-leaks? get [ continuation >>continuation ] when
|
||||
disposables get conjoin ;
|
||||
|
||||
: unregister-disposable ( obj -- )
|
||||
disposables get delete-at ;
|
||||
disposables get 2dup key? [ already-unregistered ] unless delete-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: disposable < identity-tuple disposed id ;
|
||||
TUPLE: disposable < identity-tuple
|
||||
{ id integer }
|
||||
{ disposed boolean }
|
||||
continuation ;
|
||||
|
||||
M: disposable hashcode* nip id>> ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue