From b12bbaf7ecad3b18cb446a32faa7424f3bd9efd2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 24 Aug 2009 20:21:38 -0500
Subject: [PATCH] tools.destructors: destructors. and leaks words now output a
'show instances' link which lists all relevant disposables
---
basis/tools/destructors/destructors.factor | 52 +++++++++++++++-------
core/destructors/destructors.factor | 16 +++++--
2 files changed, 49 insertions(+), 19 deletions(-)
diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor
index 4f182c6777..d032b5291a 100644
--- a/basis/tools/destructors/destructors.factor
+++ b/basis/tools/destructors/destructors.factor
@@ -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
diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor
index 39f0e9f2b9..d306da18c4 100644
--- a/core/destructors/destructors.factor
+++ b/core/destructors/destructors.factor
@@ -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>> ;