diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index 24a75304b7..7fd991b9af 100755 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words effects generalizations sequences ; IN: alien.destructors -SLOT: alien +TUPLE: alien-destructor alien ; FUNCTOR: define-destructor ( F -- ) @@ -16,12 +16,12 @@ N [ F stack-effect out>> length ] WHERE -TUPLE: F-destructor < disposable alien ; +TUPLE: F-destructor < alien-destructor ; : ( alien -- destructor ) - F-destructor new-disposable swap >>alien ; inline + F-destructor boa ; inline -M: F-destructor dispose* alien>> F N ndrop ; +M: F-destructor dispose alien>> F N ndrop ; : &F ( alien -- alien ) dup &dispose drop ; inline diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 58748b7c29..6f21d96e86 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -19,13 +19,13 @@ C: openssl-checksum ( -- ctx ) - "EVP_MD_CTX" - dup EVP_MD_CTX_init evp-md-context boa ; + evp-md-context new-disposable + "EVP_MD_CTX" dup EVP_MD_CTX_init >>handle ; -M: evp-md-context dispose +M: evp-md-context dispose* handle>> EVP_MD_CTX_cleanup drop ; : with-evp-md-context ( quot -- ) diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index 7d99493691..e8b145d37e 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -249,7 +249,8 @@ C: vocab-author } cleave ; : keyed-vocabs ( str quot -- seq ) - [ all-vocabs ] 2dip '[ [ _ swap @ member? ] filter ] assoc-map ; inline + [ all-vocabs-recursive ] 2dip + '[ [ _ swap @ member? ] filter no-prefixes ] assoc-map ; inline : tagged ( tag -- assoc ) [ vocab-tags ] keyed-vocabs ; diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index e1428fee4d..98c48c113d 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -18,7 +18,7 @@ TUPLE: epoll-mx < mx events ; max-events epoll_create dup io-error >>fd max-events "epoll-event" >>events ; -M: epoll-mx dispose fd>> close-file ; +M: epoll-mx dispose* fd>> close-file ; : make-event ( fd events -- event ) "epoll-event" diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 7bd157136a..f7b15beb54 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -17,7 +17,7 @@ TUPLE: kqueue-mx < mx events ; kqueue dup io-error >>fd max-events "kevent" >>events ; -M: kqueue-mx dispose fd>> close-file ; +M: kqueue-mx dispose* fd>> close-file ; : make-kevent ( fd filter flags -- event ) "kevent" diff --git a/basis/io/backend/unix/multiplexers/multiplexers.factor b/basis/io/backend/unix/multiplexers/multiplexers.factor index 844670d635..73d8a60310 100644 --- a/basis/io/backend/unix/multiplexers/multiplexers.factor +++ b/basis/io/backend/unix/multiplexers/multiplexers.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs sequences threads ; +USING: kernel accessors assocs sequences threads destructors ; IN: io.backend.unix.multiplexers -TUPLE: mx fd reads writes ; +TUPLE: mx < disposable fd reads writes ; : new-mx ( class -- obj ) - new + new-disposable H{ } clone >>reads H{ } clone >>writes ; inline diff --git a/basis/io/monitors/macosx/macosx.factor b/basis/io/monitors/macosx/macosx.factor index be1dcc64b6..96f178fb79 100644 --- a/basis/io/monitors/macosx/macosx.factor +++ b/basis/io/monitors/macosx/macosx.factor @@ -17,7 +17,6 @@ M:: macosx (monitor) ( path recursive? mailbox -- monitor ) path 1array 0 0 >>handle ] ; -M: macosx-monitor dispose - handle>> dispose ; +M: macosx-monitor dispose* handle>> dispose ; macosx set-io-backend diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index d8bb1ed488..cb2f552a32 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -22,8 +22,6 @@ M: object dispose-monitors ; TUPLE: monitor < disposable path queue timeout ; -M: monitor hashcode* path>> hashcode* ; - M: monitor timeout timeout>> ; M: monitor set-timeout (>>timeout) ; diff --git a/basis/io/streams/duplex/duplex-tests.factor b/basis/io/streams/duplex/duplex-tests.factor index 4903db2b1b..b64273ebb3 100644 --- a/basis/io/streams/duplex/duplex-tests.factor +++ b/basis/io/streams/duplex/duplex-tests.factor @@ -5,7 +5,7 @@ IN: io.streams.duplex.tests ! Test duplex stream close behavior TUPLE: closing-stream < disposable ; -: ( -- stream ) closing-stream new ; +: ( -- stream ) closing-stream new-disposable ; M: closing-stream dispose* drop ; diff --git a/basis/libc/libc-tests.factor b/basis/libc/libc-tests.factor index b00463127f..3dcebb5e7a 100644 --- a/basis/libc/libc-tests.factor +++ b/basis/libc/libc-tests.factor @@ -4,8 +4,8 @@ destructors kernel ; 100 malloc "block" set -[ t ] [ "block" get mallocs key? ] unit-test +[ t ] [ "block" get malloc-exists? ] unit-test [ ] [ [ "block" get &free drop ] with-destructors ] unit-test -[ f ] [ "block" get mallocs key? ] unit-test +[ f ] [ "block" get malloc-exists? ] unit-test diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 7a55b15473..926a6c4ec4 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -3,7 +3,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: alien assocs continuations alien.destructors kernel -namespaces accessors sets summary ; +namespaces accessors sets summary destructors destructors.private ; IN: libc : errno ( -- int ) @@ -26,8 +26,16 @@ IN: libc : (realloc) ( alien size -- newalien ) "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ; -: mallocs ( -- assoc ) - \ mallocs [ H{ } clone ] initialize-alien ; +! We stick malloc-ptr instances in the global disposables set +TUPLE: malloc-ptr value continuation ; + +M: malloc-ptr hashcode* value>> hashcode* ; + +M: malloc-ptr equal? + over malloc-ptr? [ [ value>> ] bi@ = ] [ 2drop f ] if ; + +: ( value -- malloc-ptr ) + malloc-ptr new swap >>value ; PRIVATE> @@ -39,11 +47,6 @@ M: bad-ptr summary : check-ptr ( c-ptr -- c-ptr ) [ bad-ptr ] unless* ; -ERROR: double-free ; - -M: double-free summary - drop "Free failed since memory is not allocated" ; - ERROR: realloc-error ptr size ; M: realloc-error summary @@ -52,16 +55,13 @@ M: realloc-error summary register-disposable ; : delete-malloc ( alien -- ) - [ - mallocs delete-at* - [ drop ] [ double-free ] if - ] when* ; + [ unregister-disposable ] when* ; : malloc-exists? ( alien -- ? ) - mallocs key? ; + disposables get key? ; PRIVATE> diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 34d9eac121..57d1fd3964 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -163,6 +163,7 @@ SYMBOL: interactive-vocabs "syntax" "tools.annotations" "tools.crossref" + "tools.destructors" "tools.disassembler" "tools.errors" "tools.memory" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index c587f842ca..b24981ed88 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -284,8 +284,6 @@ IN: tools.deploy.shaker "io-thread" "io.thread" lookup , - "mallocs" "libc.private" lookup , - "disposables" "destructors" lookup , deploy-threads? [ diff --git a/basis/tools/destructors/destructors-docs.factor b/basis/tools/destructors/destructors-docs.factor index e5a8f0318b..e01c61db00 100644 --- a/basis/tools/destructors/destructors-docs.factor +++ b/basis/tools/destructors/destructors-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations ; +USING: help.markup help.syntax help.tips quotations destructors ; IN: tools.destructors HELP: disposables. @@ -10,10 +10,13 @@ HELP: leaks { $values { "quot" quotation } } -{ $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns." } ; +{ $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns. The " { $link debug-leaks? } " variable is also switched on while the quotation runs, recording the current continuation in every newly-created disposable object." } ; + +TIP: "Use the " { $link leaks } " combinator to track down resource leaks." ; ARTICLE: "tools.destructors" "Destructor tools" "The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks." +{ $subsection debug-leaks? } { $subsection disposables. } { $subsection leaks } { $see-also "destructors" } ; diff --git a/basis/tools/destructors/destructors-tests.factor b/basis/tools/destructors/destructors-tests.factor new file mode 100644 index 0000000000..24904f76f6 --- /dev/null +++ b/basis/tools/destructors/destructors-tests.factor @@ -0,0 +1,13 @@ +USING: kernel tools.destructors tools.test destructors namespaces ; +IN: tools.destructors.tests + +f debug-leaks? set-global + +[ [ 3 throw ] leaks ] must-fail + +[ f ] [ debug-leaks? get-global ] unit-test + +[ ] [ [ ] leaks ] unit-test + +[ f ] [ debug-leaks? get-global ] unit-test + diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor index 4f182c6777..42d09d0ef9 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 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> ] 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 + t debug-leaks? set-global + [ + [ call disposables get clone ] dip + ] [ f debug-leaks? set-global ] [ ] cleanup + assoc-diff (disposables.) ; inline diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index a280ab0666..f463ae2b68 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -46,13 +46,15 @@ HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value ERROR: invalid-pixel-format-attributes world attributes ; -TUPLE: pixel-format world handle ; +TUPLE: pixel-format < disposable world handle ; : ( world attributes -- pixel-format ) 2dup (make-pixel-format) - [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ; + [ pixel-format new-disposable swap >>handle swap >>world ] + [ invalid-pixel-format-attributes ] + ?if ; -M: pixel-format dispose +M: pixel-format dispose* [ (free-pixel-format) ] [ f >>handle drop ] bi ; : pixel-format-attribute ( pixel-format attribute-name -- value ) diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 4944cba1d6..3019de4e21 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations definitions generic help.topics threads -stack-checker summary io.pathnames io.styles kernel namespaces parser -prettyprint quotations tools.crossref tools.annotations editors -tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader -words sequences classes compiler.errors compiler.units -accessors vocabs.parser macros.expander ui ui.tools.browser -ui.tools.listener ui.tools.listener.completion ui.tools.profiler -ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors -ui.gestures ui.operations ui.tools.deploy models help.tips -source-files.errors ; +stack-checker summary io.pathnames io.styles kernel namespaces +parser prettyprint quotations tools.crossref tools.annotations +editors tools.profiler tools.test tools.time tools.walker vocabs +vocabs.loader words sequences classes compiler.errors +compiler.units accessors vocabs.parser macros.expander ui +ui.tools.browser ui.tools.listener ui.tools.listener.completion +ui.tools.profiler ui.tools.inspector ui.tools.traceback +ui.commands ui.gadgets.editors ui.gestures ui.operations +ui.tools.deploy models help.tips source-files.errors destructors +libc libc.private ; IN: ui.tools.operations ! Objects @@ -182,6 +183,22 @@ M: word com-stack-effect 1quotation com-stack-effect ; { +listener+ t } } define-operation +! Disposables +[ disposable? ] \ dispose H{ } define-operation + +! Disposables with a continuation +PREDICATE: tracked-disposable < disposable + continuation>> >boolean ; + +PREDICATE: tracked-malloc-ptr < malloc-ptr + continuation>> >boolean ; + +: com-creation-traceback ( disposable -- ) + continuation>> traceback-window ; + +[ tracked-disposable? ] \ com-creation-traceback H{ { +primary+ t } } define-operation +[ tracked-malloc-ptr? ] \ com-creation-traceback H{ { +primary+ t } } define-operation + ! Operations -> commands interactor "quotation" diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 81ae923d26..afa3abf287 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -153,7 +153,7 @@ PRIVATE> [ +live-wrappers+ get adjoin ] bi ; : ( implementations -- wrapper ) - com-wrapper new-disposable swap (make-callbacks) >>vtbls + com-wrapper new-disposable swap (make-callbacks) >>callbacks dup allocate-wrapper ; M: com-wrapper dispose* diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 8a0c36b99a..a342352b90 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -1,7 +1,24 @@ USING: help.markup help.syntax libc kernel continuations io -sequences ; +sequences classes ; IN: destructors +HELP: debug-leaks? +{ $var-description "When this variable is on, " { $link new-disposable } " stores the current continuation in the " { $link disposable } "'s " { $slot "continuation" } " slot." } +{ $see-also "tools.destructors" } ; + +HELP: disposable +{ $class-description "Parent class for disposable resources. This class has three slots:" + { $list + { { $slot "disposed" } " - boolean. Set to true by " { $link dispose } ". Assert that it is false with " { $link check-disposed } "." } + { { $slot "id" } " - unique identifier. Set by " { $link new-disposable } "." } + { { $slot "continuation" } " - current continuation at construction time, for debugging. Set by " { $link new-disposable } " if " { $link debug-leaks? } " is on." } + } +"New instances must be constructed with " { $link new-disposable } " and subclasses must implement " { $link dispose* } "." } ; + +HELP: new-disposable +{ $values { "class" class } { "disposable" disposable } } +{ $description "Constructs a new instance of a subclass of " { $link disposable } ". This sets the " { $slot "id" } " slot, registers the new object with the global " { $link disposables } " set, and if " { $link debug-leaks? } " is on, stores the current continuation in the " { $slot "continuation" } " slot." } ; + HELP: dispose { $values { "disposable" "a disposable object" } } { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." @@ -52,7 +69,8 @@ HELP: dispose-each { $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ; HELP: disposables -{ $var-description "Global variable holding all disposable objects which have not been disposed of yet. The " { $link new-disposable } " word adds objects here, and the " { $link dispose } " method on disposables removes them. The " { $link "tools.destructors" } " vocabulary provides some words for working with this data." } ; +{ $var-description "Global variable holding all disposable objects which have not been disposed of yet. The " { $link new-disposable } " word adds objects here, and the " { $link dispose } " method on disposables removes them. The " { $link "tools.destructors" } " vocabulary provides some words for working with this data." } +{ $see-also "tools.destructors" } ; ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns" "Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" diff --git a/core/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor index f9d0770d02..c55b5ef423 100644 --- a/core/destructors/destructors-tests.factor +++ b/core/destructors/destructors-tests.factor @@ -1,5 +1,5 @@ USING: destructors kernel tools.test continuations accessors -namespaces sequences ; +namespaces sequences destructors.private ; IN: destructors.tests TUPLE: dispose-error ; @@ -66,3 +66,12 @@ M: dummy-destructor dispose ( obj -- ) ] ignore-errors destroyed?>> ] unit-test +TUPLE: silly-disposable < disposable ; + +M: silly-disposable dispose* drop ; + +silly-disposable new-disposable "s" set +"s" get dispose +[ "s" get unregister-disposable ] +[ disposable>> silly-disposable? ] +must-fail-with diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 39f0e9f2b9..3e57f498af 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? + >continuation ] when disposables get conjoin ; : unregister-disposable ( obj -- ) - disposables get delete-at ; + disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ; PRIVATE> -TUPLE: disposable < identity-tuple disposed id ; +TUPLE: disposable < identity-tuple +{ id integer } +{ disposed boolean } +continuation ; M: disposable hashcode* nip id>> ; @@ -39,7 +49,11 @@ M: object dispose dup disposed>> [ drop ] [ t >>disposed dispose* ] if ; M: disposable dispose - [ unregister-disposable ] [ call-next-method ] bi ; + dup disposed>> [ drop ] [ + [ unregister-disposable ] + [ call-next-method ] + bi + ] if ; : dispose-each ( seq -- ) [ diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f57dafbdc6..6387e47dfc 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -152,4 +152,10 @@ USE: debugger.threads "non-byte-array-error" unique-file binary [ "" write ] with-file-writer -] [ no-method? ] must-fail-with \ No newline at end of file +] [ no-method? ] must-fail-with + +! What happens if we close a file twice? +[ ] [ + "closing-twice" unique-file ascii + [ dispose ] [ dispose ] bi +] unit-test \ No newline at end of file diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 547e37f78a..d861178fad 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -93,7 +93,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-marshaller ( type -- quot/f ) { - { "bool" [ [ marshall-bool ] ] } + { "bool" [ [ ] ] } { "boolean" [ [ marshall-bool ] ] } { "char" [ [ marshall-primitive ] ] } { "uchar" [ [ marshall-primitive ] ] } @@ -179,7 +179,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-unmarshaller ( type -- quot/f ) { - { "bool" [ [ unmarshall-bool ] ] } + { "bool" [ [ ] ] } { "boolean" [ [ unmarshall-bool ] ] } { "char" [ [ ] ] } { "uchar" [ [ ] ] } diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor index 3945924a57..437685137c 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -9,8 +9,7 @@ C-LIBRARY: test C-INCLUDE: C-INCLUDE: - -C-TYPEDEF: char bool +C-INCLUDE: CM-FUNCTION: void outarg1 ( int* a ) *a += 2;