From cb54ca6402db79e19de05c69707dd4858b28ef35 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 20 Aug 2009 18:36:34 -0500 Subject: [PATCH 01/30] clarify 'deprecated' docs --- core/syntax/syntax-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index a988e57365..cc4b080491 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -193,7 +193,8 @@ HELP: delimiter HELP: deprecated { $syntax ": foo ... ; deprecated" } -{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ; +{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted by the " { $link "tools.errors" } " system." } +{ $notes "Code that uses deprecated words continues to function normally; the errors are purely informational. However, code that uses deprecated words should be updated, for the deprecated words are intended to be removed soon." } ; HELP: SYNTAX: { $syntax "SYNTAX: foo ... ;" } From c6b9a458815850ca2a8b6af8f606fe18d536de37 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 20 Aug 2009 18:36:55 -0500 Subject: [PATCH 02/30] $deprecated help markup --- basis/help/markup/markup.factor | 8 ++++++++ basis/help/stylesheet/stylesheet.factor | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 6f82a6f50b..2270088490 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -137,6 +137,14 @@ ALIAS: $slot $snippet ] with-nesting ] ($heading) ; +: $deprecated ( element -- ) + [ + deprecated-style get [ + last-element off + "This word is deprecated" $heading print-element + ] with-nesting + ] ($heading) ; + ! Images : $image ( element -- ) [ first write-image ] ($span) ; diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 74d7f6c115..c7811a605d 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -85,6 +85,14 @@ H{ { wrap-margin 500 } } warning-style set-global +SYMBOL: deprecated-style +H{ + { page-color COLOR: gray90 } + { border-color COLOR: red } + { border-width 5 } + { wrap-margin 500 } +} deprecated-style set-global + SYMBOL: table-content-style H{ { wrap-margin 350 } From 6f6edd79acfb4d99f99220ccd402dd1db4fb4825 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 21 Aug 2009 21:17:15 -0500 Subject: [PATCH 03/30] combinators.smart: "keep-inputs" combinator --- basis/combinators/smart/smart-docs.factor | 12 +++++++++++- basis/combinators/smart/smart.factor | 3 +++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 59b65d91cd..85545a730c 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -106,11 +106,21 @@ HELP: append-outputs-as { append-outputs append-outputs-as } related-words +HELP: drop-outputs +{ $values { "quot" quotation } } +{ $description "Calls a quotation and drops any values it leaves on the stack." } ; + +HELP: keep-inputs +{ $values { "quot" quotation } } +{ $description "Calls a quotation and preserves any values it takes off the stack." } ; + +{ drop-outputs keep-inputs } related-words ARTICLE: "combinators.smart" "Smart combinators" "A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl -"Call a quotation and discard all output values:" +"Call a quotation and discard all output values or preserve all input values:" { $subsection drop-outputs } +{ $subsection keep-inputs } "Take all input values from a sequence:" { $subsection input> '[ @ _ ndrop ] ; +MACRO: keep-inputs ( quot -- quot' ) + dup infer in>> '[ _ _ nkeep ] ; + MACRO: output>sequence ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nsequence ] ; From 81b72cb5c5d9a76295eddddc6b05764dfe6796ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 17:15:10 -0500 Subject: [PATCH 04/30] Add some unit tests --- basis/compiler/cfg/builder/builder-tests.factor | 5 +++++ basis/math/intervals/intervals-tests.factor | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 2c472bc0ff..412451f640 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -179,4 +179,9 @@ IN: compiler.cfg.builder.tests [ f ] [ [ { byte-array fixnum } declare set-alien-unsigned-1 ] [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ f ] [ + [ 1000 [ ] times ] + [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn? ] unit-test \ No newline at end of file diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index a2bdf6d98f..3b062ade17 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -23,6 +23,9 @@ IN: math.intervals.tests [ T{ interval f { 1 t } { 1 t } } ] [ 1 [a,a] ] unit-test +[ 1 0/0. [a,b] ] must-fail +[ 0/0. 1 [a,b] ] must-fail + [ t ] [ { 3 t } { 3 f } endpoint< ] unit-test [ t ] [ { 2 f } { 3 f } endpoint< ] unit-test [ f ] [ { 3 f } { 3 t } endpoint< ] unit-test @@ -350,6 +353,10 @@ comparison-ops [ [ t ] [ full-interval interval-abs [0,inf] = ] unit-test +[ t ] [ [0,inf] interval-abs [0,inf] = ] unit-test + +[ t ] [ empty-interval interval-abs empty-interval = ] unit-test + [ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test ! Test that commutative interval ops really are From d85b66536f2a29012feb874eeb7f8acbf51dbb4c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 17:45:18 -0500 Subject: [PATCH 05/30] Add docs for break and B words --- basis/tools/continuations/continuations-docs.factor | 6 ++++++ basis/tools/walker/walker-docs.factor | 5 +++++ basis/ui/tools/walker/walker-docs.factor | 1 + 3 files changed, 12 insertions(+) create mode 100644 basis/tools/continuations/continuations-docs.factor create mode 100644 basis/tools/walker/walker-docs.factor diff --git a/basis/tools/continuations/continuations-docs.factor b/basis/tools/continuations/continuations-docs.factor new file mode 100644 index 0000000000..bd69fb48ca --- /dev/null +++ b/basis/tools/continuations/continuations-docs.factor @@ -0,0 +1,6 @@ +IN: tools.continuations +USING: help.markup help.syntax ; + +HELP: break +{ $description "A breakpoint. When this word is executed, the walker tool opens with execution suspended at the breakpoint's location." } +{ $see-also "ui-walker" } ; \ No newline at end of file diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor new file mode 100644 index 0000000000..b636760634 --- /dev/null +++ b/basis/tools/walker/walker-docs.factor @@ -0,0 +1,5 @@ +IN: tools.walker +USING: help.syntax help.markup tools.continuations ; + +HELP: B +{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ; \ No newline at end of file diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index 9e73a31282..ce354da268 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/basis/ui/tools/walker/walker-docs.factor @@ -28,6 +28,7 @@ ARTICLE: "breakpoints" "Setting breakpoints" $nl "Breakpoints can be inserted directly into code:" { $subsection break } +{ $subsection POSTPONE: B } "Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ; ARTICLE: "ui-walker" "UI walker" From 5e8e83c6456da13fb5ce2f311162f2178d71517d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 17:56:58 -0500 Subject: [PATCH 06/30] bootstrap.image: smarter object folding; 500kb boot image size reduction on 64-bit --- basis/bootstrap/image/image.factor | 58 ++++++++++++++++++------------ 1 file changed, 35 insertions(+), 23 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 38cb5c12fe..ee081a14ca 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -38,11 +38,11 @@ IN: bootstrap.image ! Object cache; we only consider numbers equal if they have the ! same type -TUPLE: id obj ; +TUPLE: eql-wrapper obj ; -C: id +C: eql-wrapper -M: id hashcode* obj>> hashcode* ; +M: eql-wrapper hashcode* obj>> hashcode* ; GENERIC: (eql?) ( obj1 obj2 -- ? ) @@ -62,19 +62,27 @@ M: sequence (eql?) M: object (eql?) = ; -M: id equal? - over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; +M: eql-wrapper equal? + over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; + +TUPLE: eq-wrapper obj ; + +C: eq-wrapper + +M: eq-wrapper equal? + over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; SYMBOL: objects -: (objects) ( obj -- id assoc ) objects get ; inline +: cache-eql-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: lookup-object ( obj -- n/f ) (objects) at ; +: cache-eq-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: put-object ( n obj -- ) (objects) set-at ; +: lookup-object ( obj -- n/f ) objects get at ; -: cache-object ( obj quot -- value ) - [ (objects) ] dip '[ obj>> @ ] cache ; inline +: put-object ( n obj -- ) objects get set-at ; ! Constants @@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr ) M: bignum ' [ bignum [ emit-bignum ] emit-object - ] cache-object ; + ] cache-eql-object ; ! Fixnums @@ -277,7 +285,7 @@ M: float ' float [ align-here double>bits emit-64 ] emit-object - ] cache-object ; + ] cache-eql-object ; ! Special objects @@ -340,7 +348,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped>> ' wrapper [ emit ] emit-object ; + [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ; ! Strings : native> ( object -- object ) @@ -379,7 +387,7 @@ M: wrapper ' M: string ' #! We pool strings so that each string is only written once #! to the image - [ emit-string ] cache-object ; + [ emit-string ] cache-eql-object ; : assert-empty ( seq -- ) length 0 assert= ; @@ -390,10 +398,12 @@ M: string ' ] bi* ; M: byte-array ' - byte-array [ - dup length emit-fixnum - pad-bytes emit-bytes - ] emit-object ; + [ + byte-array [ + dup length emit-fixnum + pad-bytes emit-bytes + ] emit-object + ] cache-eq-object ; ! Tuples ERROR: tuple-removed class ; @@ -408,20 +418,22 @@ ERROR: tuple-removed class ; : emit-tuple ( tuple -- pointer ) dup class name>> "tombstone" = - [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; + [ [ (emit-tuple) ] cache-eql-object ] + [ [ (emit-tuple) ] cache-eq-object ] + if ; M: tuple ' emit-tuple ; M: tombstone ' state>> "((tombstone))" "((empty))" ? "hashtables.private" lookup def>> first - [ emit-tuple ] cache-object ; + [ emit-tuple ] cache-eql-object ; ! Arrays : emit-array ( array -- offset ) [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; -M: array ' emit-array ; +M: array ' [ emit-array ] cache-eq-object ; ! This is a hack. We need to detect arrays which are tuple ! layout arrays so that they can be internalized, but making @@ -438,7 +450,7 @@ M: tuple-layout-array ' [ [ dup integer? [ ] when ] map emit-array - ] cache-object ; + ] cache-eql-object ; ! Quotations @@ -452,7 +464,7 @@ M: quotation ' 0 emit ! xt 0 emit ! code ] emit-object - ] cache-object ; + ] cache-eql-object ; ! End of the image From 44448c3ff62c84082ce451f79ab1a99cff4190ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 19:02:40 -0500 Subject: [PATCH 07/30] iokit: don't depend on debugger, reduces terrain demo size by a bit --- basis/iokit/iokit.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/basis/iokit/iokit.factor b/basis/iokit/iokit.factor index f7ea81c0c2..529db6bf78 100755 --- a/basis/iokit/iokit.factor +++ b/basis/iokit/iokit.factor @@ -1,6 +1,6 @@ USING: alien.syntax alien.c-types core-foundation core-foundation.bundles core-foundation.dictionaries system -combinators kernel sequences debugger io accessors ; +combinators kernel sequences io accessors ; IN: iokit << @@ -136,11 +136,9 @@ FUNCTION: IOReturn IORegistryEntryCreateCFProperties ( io_registry_entry_t entry FUNCTION: char* mach_error_string ( IOReturn error ) ; -TUPLE: mach-error error-code ; -C: mach-error - -M: mach-error error. - "IOKit call failed: " print error-code>> mach_error_string print ; +TUPLE: mach-error error-code error-string ; +: ( code -- error ) + dup mach_error_string \ mach-error boa ; : mach-error ( return -- ) dup KERN_SUCCESS = [ drop ] [ throw ] if ; From 3979608b09b76f46ae313995ff7f64505cb5ea4e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 19:26:56 -0500 Subject: [PATCH 08/30] tools.deploy: faster default method stripping --- basis/tools/deploy/shaker/shaker.factor | 44 ++++++++++++++----- .../tools/deploy/shaker/strip-debugger.factor | 3 +- 2 files changed, 34 insertions(+), 13 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 35e58a0aa7..c750c70e24 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -202,17 +202,37 @@ IN: tools.deploy.shaker [ dup implementors [ "methods" word-prop delete-at ] with each ] each ] when ; +: recursive-subst ( seq old new -- ) + '[ + _ _ + { + ! old becomes new + { [ 3dup drop eq? ] [ 2nip ] } + ! recurse into arrays + { [ pick array? ] [ [ dup ] 2dip recursive-subst ] } + ! otherwise do nothing + [ 2drop ] + } cond + ] change-each ; + +: strip-default-method ( generic new-default -- ) + [ + [ "decision-tree" word-prop ] + [ "default-method" word-prop ] bi + ] dip + recursive-subst ; + +: new-default-method ( -- gensym ) + [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ; + : strip-default-methods ( -- ) + ! In a development image, each generic has its own default method. + ! This gives better error messages for runtime type errors, but + ! takes up space. For deployment we merge them all together. strip-debugger? [ "Stripping default methods" show - [ - [ generic? ] instances - [ "No method" throw ] (( -- * )) define-temp - dup t "default" set-word-prop - '[ - [ _ "default-method" set-word-prop ] [ make-generic ] bi - ] each - ] with-compilation-unit + [ single-generic? ] instances + new-default-method '[ _ strip-default-method ] each ] when ; : strip-vocab-globals ( except names -- words ) @@ -361,8 +381,8 @@ IN: tools.deploy.shaker [ compress-object? ] [ ] "objects" compress ; : remain-compiled ( old new -- old new ) - #! Quotations which were formerly compiled must remain - #! compiled. + ! Quotations which were formerly compiled must remain + ! compiled. 2dup [ 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and [ nip jit-compile ] [ 2drop ] if @@ -383,7 +403,9 @@ SYMBOL: deploy-vocab [ boot ] % init-hooks get values concat % strip-debugger? [ , ] [ - ! Don't reference try directly + ! Don't reference 'try' directly since we don't want + ! to pull in the debugger and prettyprinter into every + ! deployed app [:c] [print-error] '[ diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index db7eb63bbf..b7565e7d9e 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -12,7 +12,6 @@ IN: debugger "threads" vocab [ [ "error-in-thread" "threads" lookup - [ die 2drop ] - define + [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi ] with-compilation-unit ] when From f82627e736906f83236bd11c854e0ba9afeddc4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Aug 2009 19:39:32 -0500 Subject: [PATCH 09/30] math.intervals: comment out questionable unit tests --- basis/math/intervals/intervals-tests.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 3b062ade17..4e44fc1208 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -23,8 +23,9 @@ IN: math.intervals.tests [ T{ interval f { 1 t } { 1 t } } ] [ 1 [a,a] ] unit-test -[ 1 0/0. [a,b] ] must-fail -[ 0/0. 1 [a,b] ] must-fail +! Not sure how to handle NaNs yet... +! [ 1 0/0. [a,b] ] must-fail +! [ 0/0. 1 [a,b] ] must-fail [ t ] [ { 3 t } { 3 f } endpoint< ] unit-test [ t ] [ { 2 f } { 3 f } endpoint< ] unit-test From 17a08cb07a926a2198771dd9879c6c20fe7e95e0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 22 Aug 2009 20:15:13 -0500 Subject: [PATCH 10/30] gpu.shaders docs corrections --- extra/gpu/shaders/shaders-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index d59fa1bc39..33b97d7a82 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -111,7 +111,7 @@ HELP: output-index { $notes "Named fragment shader outputs require OpenGL 3.0 or later and GLSL 1.30 or later, or OpenGL 2.0 or later and GLSL 1.20 or earlier with the " { $snippet "GL_EXT_gpu_shader4" } " extension." } ; HELP: program -{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated in a context with " { $link } "." } ; +{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated for a context with " { $link } "." } ; HELP: program-instance { $class-description "A " { $snippet "program-instance" } " is a shader " { $link program } " that has been compiled and linked for a graphics context using " { $link } "." } ; @@ -120,10 +120,10 @@ HELP: refresh-program { $values { "program" program } } -{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those programs. If the new source code fails to compile or link, the existing instances are untouched; otherwise, they are updated on the fly to reference the newly compiled code." } ; +{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those shaders. If any of the new source code fails to compile or link, the existing valid shader and program instances will remain untouched. However, subsequent attempts to compile new shader or program instances will still attempt to use the new source code. If the compilation and linking succeed, the existing shader and program instances will be updated on the fly to reference the newly compiled code." } ; HELP: shader -{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated in a context with " { $link } "." } ; +{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated for a context with " { $link } "." } ; HELP: shader-instance { $class-description "A " { $snippet "shader-instance" } " is a " { $link shader } " that has been compiled for a graphics context using " { $link } "." } ; From b14dd8ab6781828850ef31024f5056718575f14c Mon Sep 17 00:00:00 2001 From: sheeple Date: Sat, 22 Aug 2009 20:23:28 -0500 Subject: [PATCH 11/30] cpu.ppc: integer>fixnum scratch area overlapped with the rest of stack frame, very bad --- basis/cpu/ppc/ppc.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b8e5bdbe10..d6674e7097 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -96,10 +96,7 @@ HOOK: reserved-area-size os ( -- n ) ! frame, 8 bytes in size. This is in the param-save area so it ! does not overlap with spill slots. : scratch@ ( n -- offset ) - stack-frame get total-size>> - factor-area-size - - param-save-size - - + ; + factor-area-size + ; ! GC root area : gc-root@ ( n -- offset ) From 4923c66cc9fc8f8c4bbbde8ee95985c970175d69 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 22 Aug 2009 21:03:39 -0500 Subject: [PATCH 12/30] memory.piles: and convenience words --- extra/memory/piles/piles-docs.factor | 16 ++++++++++++++++ extra/memory/piles/piles.factor | 6 ++++++ 2 files changed, 22 insertions(+) diff --git a/extra/memory/piles/piles-docs.factor b/extra/memory/piles/piles-docs.factor index c2bc29af1c..108c3535c9 100644 --- a/extra/memory/piles/piles-docs.factor +++ b/extra/memory/piles/piles-docs.factor @@ -32,6 +32,20 @@ HELP: pile-alloc } { $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ; +HELP: +{ $values + { "pile" pile } { "n" integer } { "c-type" "a C type" } + { "alien" alien } +} +{ $description "Requests enough space from a " { $link pile } " to hold " { $snippet "n" } " values of " { $snippet "c-type" } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ; + +HELP: +{ $values + { "pile" pile } { "c-type" "a C type" } + { "alien" alien } +} +{ $description "Requests enough space from a " { $link pile } " to hold a value of " { $snippet "c-type" } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ; + HELP: pile-empty { $values { "pile" pile } @@ -42,6 +56,8 @@ ARTICLE: "memory.piles" "Piles" "A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning." { $subsection } { $subsection pile-alloc } +{ $subsection } +{ $subsection } { $subsection pile-align } { $subsection pile-empty } "An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ; diff --git a/extra/memory/piles/piles.factor b/extra/memory/piles/piles.factor index b8a79b4824..651bf2ec6c 100644 --- a/extra/memory/piles/piles.factor +++ b/extra/memory/piles/piles.factor @@ -28,6 +28,12 @@ M: pile dispose [ + ] curry change-offset drop ] 2tri ; +: ( pile c-type -- alien ) + heap-size pile-alloc ; inline + +: ( pile n c-type -- alien ) + heap-size * pile-alloc ; inline + : pile-align ( pile align -- pile ) [ align ] curry change-offset ; From 556adeb9b4b15e6fe6941a9189ad89f982436817 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 23 Aug 2009 09:51:12 -0500 Subject: [PATCH 13/30] handle RGBA pngs (when inflate finally works) --- basis/images/png/png.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 2469a6a72c..86247351c9 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -95,7 +95,11 @@ ERROR: unimplemented-color-type image ; unimplemented-color-type ; : decode-truecolor-alpha ( loading-png -- loading-png ) - unimplemented-color-type ; + [ ] dip { + [ png-image-bytes >>bitmap ] + [ [ width>> ] [ height>> ] bi 2array >>dim ] + [ drop RGBA >>component-order ubyte-components >>component-type ] + } cleave ; : decode-png ( loading-png -- loading-png ) dup color-type>> { From 387007abfe10610dc21a35977668da6fe185fe10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Aug 2009 17:54:37 -0500 Subject: [PATCH 14/30] tools.deploy.shaker: fix regression; strip-compiler-classes wasn't working --- basis/tools/deploy/shaker/shaker.factor | 31 +++++++++++++++++++++---- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index c750c70e24..a0eb9b5c7f 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -6,7 +6,7 @@ vocabs sequences sequences.private words memory kernel.private continuations io vocabs.loader system strings sets vectors quotations byte-arrays sorting compiler.units definitions generic generic.standard generic.single tools.deploy.config combinators -classes slots.private ; +classes classes.builtin slots.private grouping ; QUALIFIED: bootstrap.stage2 QUALIFIED: command-line QUALIFIED: compiler.errors @@ -194,12 +194,31 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: compiler-classes ( -- seq ) + { "compiler" "stack-checker" } + [ child-vocabs [ words ] map concat [ class? ] filter ] + map concat unique ; + +: prune-decision-tree ( tree classes -- ) + [ tuple class>type ] 2dip '[ + dup array? [ + [ + dup array? [ + [ + 2 group + [ drop _ key? not ] assoc-filter + concat + ] map + ] when + ] map + ] when + ] change-nth ; + : strip-compiler-classes ( -- ) strip-dictionary? [ "Stripping compiler classes" show - { "compiler" "stack-checker" } - [ child-vocabs [ words ] map concat [ class? ] filter ] map concat - [ dup implementors [ "methods" word-prop delete-at ] with each ] each + [ single-generic? ] instances + compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each ] when ; : recursive-subst ( seq old new -- ) @@ -440,6 +459,8 @@ SYMBOL: deploy-vocab "vocab:tools/deploy/shaker/next-methods.factor" run-file ; : (clear-megamorphic-cache) ( i array -- ) + ! Can't do any dispatch while clearing caches since that + ! might leave them in an inconsistent state. 2dup 1 slot < [ 2dup [ f ] 2dip set-array-nth [ 1 + ] dip (clear-megamorphic-cache) @@ -465,8 +486,8 @@ SYMBOL: deploy-vocab compute-next-methods strip-init-hooks strip-c-io - strip-compiler-classes strip-default-methods + strip-compiler-classes f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot find-megamorphic-caches From 449be040f8ca571672028c4145ad8c475d470a0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Aug 2009 19:07:21 -0500 Subject: [PATCH 15/30] Use utf8 instead of ascii encoding in a couple of places to avoid pulling in ascii into deployed apps --- basis/cocoa/views/views.factor | 2 +- basis/colors/constants/constants.factor | 8 ++++---- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/ui/backend/cocoa/views/views.factor | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index f65fddac58..ce785dd8df 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: specialized-arrays.int arrays kernel math namespaces make +USING: arrays kernel math namespaces make cocoa cocoa.messages cocoa.classes core-graphics core-graphics.types sequences continuations accessors ; IN: cocoa.views diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 38339577cf..98e7d43411 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs math math.parser memoize -io.encodings.ascii io.files lexer parser -colors sequences splitting combinators.smart ascii ; +USING: kernel assocs math math.parser memoize io.encodings.utf8 +io.files lexer parser colors sequences splitting +combinators.smart ascii ; IN: colors.constants assoc ; MEMO: rgb.txt ( -- assoc ) - "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ; + "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ; PRIVATE> diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index e05704e623..c40a19851f 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -7,7 +7,7 @@ cocoa.views cocoa.windows combinators command-line core-foundation core-foundation.run-loop core-graphics core-graphics.types destructors fry generalizations io.thread kernel libc literals locals math math.bitwise math.rectangles memory -namespaces sequences specialized-arrays.int threads ui +namespaces sequences threads ui ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private ui.private words.symbol ; diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index a7b9fd3801..ffff15a911 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.strings arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types -cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets +cocoa.windows sequences io.encodings.utf8 ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures core-foundation.strings core-graphics core-graphics.types threads combinators math.rectangles ; @@ -220,7 +220,7 @@ CLASS: { { "validateUserInterfaceItem:" "char" { "id" "SEL" "id" } [ nip -> action - 2dup [ window ] [ ascii alien>string ] bi* validate-action + 2dup [ window ] [ utf8 alien>string ] bi* validate-action [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if ] } From e42216a569dfb1112d899bff41b2475597ce9e5b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Aug 2009 19:18:12 -0500 Subject: [PATCH 16/30] tools.deploy.shaker: more compact next-method shaking --- basis/tools/deploy/shaker/next-methods.factor | 5 +++-- basis/tools/deploy/shaker/shaker.factor | 8 +++----- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/tools/deploy/shaker/next-methods.factor b/basis/tools/deploy/shaker/next-methods.factor index 2bff407525..4e771d24fd 100644 --- a/basis/tools/deploy/shaker/next-methods.factor +++ b/basis/tools/deploy/shaker/next-methods.factor @@ -1,4 +1,5 @@ -USING: words ; +USING: kernel words ; IN: generic -: next-method-quot ( method -- quot ) "next-method-quot" word-prop ; +: (call-next-method) ( method -- ) + dup "next-method" word-prop execute ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index a0eb9b5c7f..c6b6731321 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -443,17 +443,15 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; -: unsafe-next-method-quot ( method -- quot ) +: next-method* ( method -- quot ) [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - next-method 1quotation ; + next-method ; : compute-next-methods ( -- ) [ standard-generic? ] instances [ "methods" word-prop [ - nip dup - unsafe-next-method-quot - "next-method-quot" set-word-prop + nip dup next-method* "next-method" set-word-prop ] assoc-each ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; From 46045c882eddf0a13dcc2907a6e4a89f082b9acf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 02:26:13 -0500 Subject: [PATCH 17/30] Disposables are now registered in a global disposables set. To take advantage of this, subclass disposable instead of providing a disposed slot and call new-disposable instead of new. tools.disposables defines two words, 'disposable.' and 'leaks', to help track down resource lifetime problems --- basis/alien/destructors/destructors.factor | 5 +-- basis/bootstrap/tools/tools.factor | 1 + basis/cache/cache.factor | 4 +-- basis/concurrency/mailboxes/mailboxes.factor | 4 +-- .../core-foundation/fsevents/fsevents.factor | 8 ++--- basis/core-text/core-text.factor | 19 +++++++---- basis/help/handbook/handbook.factor | 3 +- basis/io/backend/unix/unix.factor | 23 +++++++------ basis/io/backend/windows/windows.factor | 22 +++--------- basis/io/mmap/mmap.factor | 21 ++++++------ basis/io/monitors/linux/linux.factor | 2 +- basis/io/monitors/monitors.factor | 4 +-- basis/io/monitors/recursive/recursive.factor | 2 +- basis/io/ports/ports.factor | 4 +-- .../io/sockets/secure/openssl/openssl.factor | 18 +++++----- basis/io/sockets/secure/secure.factor | 2 +- basis/io/sockets/sockets-tests.factor | 4 +++ basis/opengl/textures/textures.factor | 14 ++++---- basis/pango/layouts/layouts.factor | 4 +-- basis/tools/deploy/shaker/shaker.factor | 13 ++++++- .../deploy/shaker/strip-destructors.factor | 6 ++++ basis/tools/destructors/authors.txt | 1 + .../tools/destructors/destructors-docs.factor | 21 ++++++++++++ basis/tools/destructors/destructors.factor | 31 +++++++++++++++++ basis/windows/com/wrapper/wrapper.factor | 4 +-- basis/windows/uniscribe/uniscribe.factor | 4 +-- core/destructors/destructors-docs.factor | 34 ++++++++++++++----- core/destructors/destructors.factor | 29 ++++++++++++++-- core/io/streams/c/c.factor | 9 +++-- 29 files changed, 216 insertions(+), 100 deletions(-) create mode 100644 basis/tools/deploy/shaker/strip-destructors.factor create mode 100644 basis/tools/destructors/authors.txt create mode 100644 basis/tools/destructors/destructors-docs.factor create mode 100644 basis/tools/destructors/destructors.factor diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index 374d6425c4..24a75304b7 100755 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -16,9 +16,10 @@ N [ F stack-effect out>> length ] WHERE -TUPLE: F-destructor alien disposed ; +TUPLE: F-destructor < disposable alien ; -: ( alien -- destructor ) f F-destructor boa ; inline +: ( alien -- destructor ) + F-destructor new-disposable swap >>alien ; inline M: F-destructor dispose* alien>> F N ndrop ; diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index e5e7e869c8..6bdfd6241c 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -8,6 +8,7 @@ IN: bootstrap.tools "tools.crossref" "tools.errors" "tools.deploy" + "tools.destructors" "tools.disassembler" "tools.memory" "tools.profiler" diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor index 3dab1acac8..a226500c63 100644 --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -3,10 +3,10 @@ USING: kernel assocs math accessors destructors fry sequences ; IN: cache -TUPLE: cache-assoc assoc max-age disposed ; +TUPLE: cache-assoc < disposable assoc max-age ; : ( -- cache ) - H{ } clone 10 f cache-assoc boa ; + cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ; > notify-all ; : ( -- mailbox ) - f mailbox boa ; + mailbox new-disposable >>threads >>data ; : mailbox-empty? ( mailbox -- bool ) data>> deque-empty? ; diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 1956cd9c20..4aa531f182 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -181,15 +181,15 @@ SYMBOL: event-stream-callbacks } "cdecl" [ (master-event-source-callback) ] alien-callback ; -TUPLE: event-stream info handle disposed ; +TUPLE: event-stream < disposable info handle ; : ( quot paths latency flags -- event-stream ) [ - add-event-source-callback dup - [ master-event-source-callback ] dip + add-event-source-callback + [ master-event-source-callback ] keep ] 3dip dup enable-event-stream - f event-stream boa ; + event-stream new-disposable swap >>handle swap >>info ; M: event-stream dispose* { diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index de3b5ac715..4add71b08f 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -46,7 +46,7 @@ ERROR: not-a-string object ; CTLineCreateWithAttributedString ] with-destructors ; -TUPLE: line line metrics image loc dim disposed ; +TUPLE: line < disposable line metrics image loc dim ; : typographic-bounds ( line -- width ascent descent leading ) 0 0 0 @@ -109,6 +109,8 @@ TUPLE: line line metrics image loc dim disposed ; :: ( font string -- line ) [ + line new-disposable + [let* | open-font [ font cache-font ] line [ string open-font font foreground>> |CFRelease ] @@ -120,7 +122,11 @@ TUPLE: line line metrics image loc dim disposed ; ext [ (loc) (dim) [ + ceiling ] 2map ] dim [ ext loc [ - >integer ] 2map ] metrics [ open-font line compute-line-metrics ] | - line metrics + + line >>line + + metrics >>metrics + dim [ { [ font dim fill-background ] @@ -128,11 +134,12 @@ TUPLE: line line metrics image loc dim disposed ; [ loc set-text-position ] [ [ line ] dip CTLineDraw ] } cleave - ] make-bitmap-image - metrics loc dim line-loc - metrics metrics>dim + ] make-bitmap-image >>image + + metrics loc dim line-loc >>loc + + metrics metrics>dim >>dim ] - f line boa ] with-destructors ; M: line dispose* line>> CFRelease ; diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 1c63360025..5db362d9bc 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -287,9 +287,9 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Debugging" } { $subsection "prettyprint" } { $subsection "inspector" } +{ $subsection "tools.inference" } { $subsection "tools.annotations" } { $subsection "tools.deprecation" } -{ $subsection "tools.inference" } { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } @@ -299,6 +299,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $subsection "profiling" } { $subsection "tools.memory" } { $subsection "tools.threads" } +{ $subsection "tools.destructors" } { $subsection "tools.disassembler" } { $heading "Deployment" } { $subsection "tools.deploy" } ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 1a52ce6f34..4b7ef4b40f 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -4,14 +4,15 @@ USING: alien alien.c-types alien.syntax generic assocs kernel kernel.private math io.ports sequences strings sbufs threads unix vectors io.buffers io.backend io.encodings math.parser continuations system libc namespaces make io.timeouts -io.encodings.utf8 destructors accessors summary combinators -locals unix.time fry io.backend.unix.multiplexers ; +io.encodings.utf8 destructors destructors.private accessors +summary combinators locals unix.time fry +io.backend.unix.multiplexers ; QUALIFIED: io IN: io.backend.unix GENERIC: handle-fd ( handle -- fd ) -TUPLE: fd fd disposed ; +TUPLE: fd < disposable fd ; : init-fd ( fd -- fd ) [ @@ -25,14 +26,16 @@ TUPLE: fd fd disposed ; #! since on OS X 10.3, this operation fails from init-io #! when running the Factor.app (presumably because fd 0 and #! 1 are closed). - f fd boa ; + fd new-disposable swap >>fd ; M: fd dispose dup disposed>> [ drop ] [ - [ cancel-operation ] - [ t >>disposed drop ] - [ fd>> close-file ] - tri + { + [ cancel-operation ] + [ t >>disposed drop ] + [ unregister-disposable ] + [ fd>> close-file ] + } cleave ] if ; M: fd handle-fd dup check-disposed fd>> ; @@ -133,7 +136,7 @@ M: unix io-multiplex ( ms/f -- ) ! pipe to non-blocking, and read from it instead of the real ! stdin. Very crufty, but it will suffice until we get native ! threading support at the language level. -TUPLE: stdin control size data disposed ; +TUPLE: stdin < disposable control size data ; M: stdin dispose* [ @@ -168,7 +171,7 @@ M: stdin refill : data-read-fd ( -- fd ) &: stdin_read *uint ; : ( -- stdin ) - stdin new + stdin new-disposable control-write-fd >>control size-read-fd init-fd >>size data-read-fd >>data ; diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index fde5cf9b12..5922e217b0 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -7,33 +7,21 @@ windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitwise accessors init sets assocs ; IN: io.backend.windows -: win32-handles ( -- assoc ) - \ win32-handles [ H{ } clone ] initialize-alien ; - -TUPLE: win32-handle < identity-tuple handle disposed ; - -M: win32-handle hashcode* handle>> hashcode* ; +TUPLE: win32-handle < disposable handle ; : set-inherit ( handle ? -- ) [ handle>> HANDLE_FLAG_INHERIT ] dip >BOOLEAN SetHandleInformation win32-error=0/f ; : new-win32-handle ( handle class -- win32-handle ) - new swap >>handle - dup f set-inherit - dup win32-handles conjoin ; + new-disposable swap >>handle + dup f set-inherit ; : ( handle -- win32-handle ) win32-handle new-win32-handle ; -ERROR: disposing-twice ; - -: unregister-handle ( handle -- ) - win32-handles delete-at* - [ t >>disposed drop ] [ disposing-twice ] if ; - M: win32-handle dispose* ( handle -- ) - [ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ; + handle>> CloseHandle win32-error=0/f ; TUPLE: win32-file < win32-handle ptr ; @@ -54,7 +42,7 @@ HOOK: add-completion io-backend ( port -- ) |dispose dup add-completion ; -: share-mode ( -- fixnum ) +: share-mode ( -- n ) { FILE_SHARE_READ FILE_SHARE_WRITE diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 9a4443e8e5..aa3ac624a0 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -6,30 +6,29 @@ accessors vocabs.loader combinators alien.c-types math ; IN: io.mmap -TUPLE: mapped-file address handle length disposed ; +TUPLE: mapped-file < disposable address handle length ; HOOK: (mapped-file-reader) os ( path length -- address handle ) HOOK: (mapped-file-r/w) os ( path length -- address handle ) -ERROR: bad-mmap-size path size ; +ERROR: bad-mmap-size n ; > ] bi - dup 0 <= [ bad-mmap-size ] when ; +: prepare-mapped-file ( path quot -- mapped-file path' length ) + [ + [ normalize-path ] [ file-info size>> ] bi + [ dup 0 <= [ bad-mmap-size ] [ 2drop ] if ] + [ nip mapped-file new-disposable swap >>length ] + ] dip 2tri [ >>address ] [ >>handle ] bi* ; inline PRIVATE> : ( path -- mmap ) - prepare-mapped-file - [ (mapped-file-reader) ] keep - f mapped-file boa ; + [ (mapped-file-reader) ] prepare-mapped-file ; : ( path -- mmap ) - prepare-mapped-file - [ (mapped-file-r/w) ] keep - f mapped-file boa ; + [ (mapped-file-r/w) ] prepare-mapped-file ; HOOK: close-mapped-file io-backend ( mmap -- ) diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 9097e7e864..9b3688d023 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -12,7 +12,7 @@ SYMBOL: watches SYMBOL: inotify -TUPLE: linux-monitor < monitor wd inotify watches disposed ; +TUPLE: linux-monitor < monitor wd inotify watches ; : ( wd path mailbox -- monitor ) linux-monitor new-monitor diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index cc8cea37d2..d8bb1ed488 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -20,7 +20,7 @@ M: object dispose-monitors ; [ dispose-monitors ] [ ] cleanup ] with-scope ; inline -TUPLE: monitor < identity-tuple path queue timeout ; +TUPLE: monitor < disposable path queue timeout ; M: monitor hashcode* path>> hashcode* ; @@ -29,7 +29,7 @@ M: monitor timeout timeout>> ; M: monitor set-timeout (>>timeout) ; : new-monitor ( path mailbox class -- monitor ) - new + new-disposable swap >>queue swap >>path ; inline diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 943345bf18..75dfd234a8 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -8,7 +8,7 @@ IN: io.monitors.recursive ! Simulate recursive monitors on platforms that don't have them -TUPLE: recursive-monitor < monitor children thread ready disposed ; +TUPLE: recursive-monitor < monitor children thread ready ; : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ; diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index b2d71fd535..49f6166e00 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -10,14 +10,14 @@ IN: io.ports SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -TUPLE: port handle timeout disposed ; +TUPLE: port < disposable handle timeout ; M: port timeout timeout>> ; M: port set-timeout (>>timeout) ; : ( handle class -- port ) - new swap >>handle ; inline + new-disposable swap >>handle ; inline TUPLE: buffered-port < port { buffer buffer } ; diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 07246354e3..8f596da0bd 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -78,9 +78,9 @@ TUPLE: openssl-context < secure-context aliens sessions ; SSL_CTX_set_verify_depth ] [ drop ] if ; -TUPLE: bio handle disposed ; +TUPLE: bio < disposable handle ; -: ( handle -- bio ) f bio boa ; +: ( handle -- bio ) bio new-disposable swap >>handle ; M: bio dispose* handle>> BIO_free ssl-error ; @@ -94,9 +94,9 @@ M: bio dispose* handle>> BIO_free ssl-error ; SSL_CTX_set_tmp_dh ssl-error ] [ drop ] if ; -TUPLE: rsa handle disposed ; +TUPLE: rsa < disposable handle ; -: ( handle -- rsa ) f rsa boa ; +: ( handle -- rsa ) rsa new-disposable swap >>handle ; M: rsa dispose* handle>> RSA_free ; @@ -109,7 +109,7 @@ M: rsa dispose* handle>> RSA_free ; SSL_CTX_set_tmp_rsa ssl-error ; : ( config ctx -- context ) - openssl-context new + openssl-context new-disposable swap >>handle swap >>config V{ } clone >>aliens @@ -139,7 +139,7 @@ M: openssl-context dispose* [ handle>> SSL_CTX_free ] tri ; -TUPLE: ssl-handle file handle connected disposed ; +TUPLE: ssl-handle < disposable file handle connected ; SYMBOL: default-secure-context @@ -151,8 +151,10 @@ SYMBOL: default-secure-context ] unless* ; : ( fd -- ssl ) - current-secure-context handle>> SSL_new dup ssl-error - f f ssl-handle boa ; + ssl-handle new-disposable + current-secure-context handle>> SSL_new + dup ssl-error >>handle + swap >>file ; M: ssl-handle dispose* [ handle>> SSL_free ] [ file>> dispose ] bi ; diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index bff2dbaf1a..e654caf0b8 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -29,7 +29,7 @@ ephemeral-key-bits ; "vocab:openssl/cacert.pem" >>ca-file t >>verify ; -TUPLE: secure-context config handle disposed ; +TUPLE: secure-context < disposable config handle ; HOOK: secure-socket-backend ( config -- context ) diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index dc0c698699..a4a3f0702b 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -79,6 +79,8 @@ concurrency.promises threads io.streams.string ; ! See what happens if other end is closed [ ] [ "port" set ] unit-test +[ ] [ "datagram3" get dispose ] unit-test + [ ] [ [ "127.0.0.1" 0 utf8 @@ -93,6 +95,8 @@ concurrency.promises threads io.streams.string ; [ "hello" f ] [ "port" get ?promise utf8 [ + 1 seconds input-stream get set-timeout + 1 seconds output-stream get set-timeout "hi\n" write flush readln readln ] with-client ] unit-test diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 34cb14a442..528aaaa12f 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -268,7 +268,7 @@ DEFER: make-texture > ] keep draw-textured-rect ] make-dlist ; : ( image loc -- texture ) - single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi + single-texture new-disposable swap >>loc swap [ >>image ] [ dim>> >>dim ] bi dup image>> dim>> product 0 = [ dup texture-coords >>texture-coords dup image>> make-texture >>texture @@ -347,7 +347,7 @@ M: single-texture draw-scaled-texture dup texture>> [ draw-textured-rect ] [ 2drop ] if ] if ; -TUPLE: multi-texture grid display-list loc disposed ; +TUPLE: multi-texture < disposable grid display-list loc ; : image-locs ( image-grid -- loc-grid ) [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi @@ -373,11 +373,9 @@ TUPLE: multi-texture grid display-list loc disposed ; : ( image-grid loc -- multi-texture ) [ - [ - dup - make-textured-grid-display-list - ] keep - f multi-texture boa + [ multi-texture new-disposable ] 2dip + [ nip >>loc ] [ >>grid ] 2bi + dup grid>> make-textured-grid-display-list >>display-list ] with-destructors ; M: multi-texture draw-scaled-texture nip draw-texture ; diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index 25aee74ca4..88c6f17093 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -60,7 +60,7 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ; DESTRUCTOR: pango_layout_iter_free -TUPLE: layout font string selection layout metrics ink-rect logical-rect image disposed ; +TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ; SYMBOL: dpi @@ -186,7 +186,7 @@ MEMO: missing-font-metrics ( font -- metrics ) : ( font string -- line ) [ - layout new + layout new-disposable swap unpack-selection swap >>font dup [ string>> ] [ font>> ] bi >>layout diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index c6b6731321..c587f842ca 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -24,11 +24,12 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show { + "alien.strings" "command-line" "cpu.x86" + "destructors" "environment" "libc" - "alien.strings" } [ init-hooks get delete-at ] each deploy-threads? get [ @@ -65,6 +66,13 @@ IN: tools.deploy.shaker run-file ] when ; +: strip-destructors ( -- ) + "libc" vocab [ + "Stripping destructor debug code" show + "vocab:tools/deploy/shaker/strip-destructors.factor" + run-file + ] when ; + : strip-call ( -- ) "Stripping stack effect checking from call( and execute(" show "vocab:tools/deploy/shaker/strip-call.factor" run-file ; @@ -278,6 +286,8 @@ IN: tools.deploy.shaker "mallocs" "libc.private" lookup , + "disposables" "destructors" lookup , + deploy-threads? [ "initial-thread" "threads" lookup , ] unless @@ -478,6 +488,7 @@ SYMBOL: deploy-vocab : strip ( -- ) init-stripper strip-libc + strip-destructors strip-call strip-cocoa strip-debugger diff --git a/basis/tools/deploy/shaker/strip-destructors.factor b/basis/tools/deploy/shaker/strip-destructors.factor new file mode 100644 index 0000000000..86c08ebcb5 --- /dev/null +++ b/basis/tools/deploy/shaker/strip-destructors.factor @@ -0,0 +1,6 @@ +USE: kernel +IN: destructors.private + +: register-disposable ( obj -- ) drop ; inline + +: unregister-disposable ( obj -- ) drop ; inline diff --git a/basis/tools/destructors/authors.txt b/basis/tools/destructors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/tools/destructors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/tools/destructors/destructors-docs.factor b/basis/tools/destructors/destructors-docs.factor new file mode 100644 index 0000000000..e5a8f0318b --- /dev/null +++ b/basis/tools/destructors/destructors-docs.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax quotations ; +IN: tools.destructors + +HELP: disposables. +{ $description "Print the number of disposable objects of each class." } ; + +HELP: leaks +{ $values + { "quot" quotation } +} +{ $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns." } ; + +ARTICLE: "tools.destructors" "Destructor tools" +"The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks." +{ $subsection disposables. } +{ $subsection leaks } +{ $see-also "destructors" } ; + +ABOUT: "tools.destructors" diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor new file mode 100644 index 0000000000..4f182c6777 --- /dev/null +++ b/basis/tools/destructors/destructors.factor @@ -0,0 +1,31 @@ +! 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 ; +IN: tools.destructors + +alist sort-keys simple-table. ; + +PRIVATE> + +: disposables. ( -- ) + disposable-tally (disposables.) ; + +: leaks ( quot -- ) + disposable-tally [ call disposable-tally ] dip subtract-values + (disposables.) ; inline diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index beac4b6c27..81ae923d26 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -6,7 +6,7 @@ destructors fry math.parser generalizations sets specialized-arrays.alien specialized-arrays.direct.alien ; IN: windows.com.wrapper -TUPLE: com-wrapper callbacks vtbls disposed ; +TUPLE: com-wrapper < disposable callbacks vtbls ; [ +live-wrappers+ get adjoin ] bi ; : ( implementations -- wrapper ) - (make-callbacks) f f com-wrapper boa + com-wrapper new-disposable swap (make-callbacks) >>vtbls dup allocate-wrapper ; M: com-wrapper dispose* diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 7c5c26c2da..457f4bc9f0 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -7,7 +7,7 @@ windows.offscreen windows.gdi32 windows.ole32 windows.types windows.fonts opengl.textures locals windows.errors ; IN: windows.uniscribe -TUPLE: script-string font string metrics ssa size image disposed ; +TUPLE: script-string < disposable font string metrics ssa size image ; : line-offset>x ( n script-string -- x ) 2dup string>> length = [ @@ -89,7 +89,7 @@ TUPLE: script-string font string metrics ssa size image disposed ; TEXTMETRIC>metrics ; : ( font string -- script-string ) - [ script-string new ] 2dip + [ script-string new-disposable ] 2dip [ >>font ] [ >>string ] bi* [ { diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index ed7d433026..8a0c36b99a 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -8,8 +8,8 @@ HELP: dispose $nl "No further operations can be performed on a disposable object after this call." $nl -"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." } -{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, inherit from the " { $link disposable } " class and implement the " { $link dispose* } " method instead." } +{ $notes "You must dispose of disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." $nl "The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ; @@ -51,6 +51,9 @@ HELP: dispose-each { "seq" sequence } } { $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." } ; + 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:" { $code @@ -58,12 +61,9 @@ ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns" } "The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ; -ARTICLE: "destructors" "Deterministic resource disposal" -"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability." -$nl -"Disposable object protocol:" +ARTICLE: "destructors-using" "Using destructors" +"Disposing of an object:" { $subsection dispose } -{ $subsection dispose* } "Utility word for scoped disposal:" { $subsection with-disposal } "Utility word for disposing multiple objects:" @@ -71,7 +71,23 @@ $nl "Utility words for more complex disposal patterns:" { $subsection with-destructors } { $subsection &dispose } -{ $subsection |dispose } -{ $subsection "destructors-anti-patterns" } ; +{ $subsection |dispose } ; + +ARTICLE: "destructors-extending" "Writing new destructors" +"Superclass for disposable objects:" +{ $subsection disposable } +"Parametrized constructor for disposable objects:" +{ $subsection new-disposable } +"Generic disposal word:" +{ $subsection dispose* } +"Global set of disposable objects:" +{ $subsection disposables } ; + +ARTICLE: "destructors" "Deterministic resource disposal" +"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability." +{ $subsection "destructors-using" } +{ $subsection "destructors-extending" } +{ $subsection "destructors-anti-patterns" } +{ $see-also "tools.destructors" } ; ABOUT: "destructors" diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 9a470d53c1..39f0e9f2b9 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -1,10 +1,30 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! 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 ; +sequences vectors sets assocs init ; IN: destructors -TUPLE: disposable disposed ; +SYMBOL: disposables + +[ H{ } clone disposables set-global ] "destructors" add-init-hook + + + +TUPLE: disposable < identity-tuple disposed id ; + +M: disposable hashcode* nip id>> ; + +: new-disposable ( class -- disposable ) + new \ disposable counter >>id + dup register-disposable ; inline GENERIC: dispose* ( disposable -- ) @@ -18,6 +38,9 @@ GENERIC: dispose ( disposable -- ) M: object dispose dup disposed>> [ drop ] [ t >>disposed dispose* ] if ; +M: disposable dispose + [ unregister-disposable ] [ call-next-method ] bi ; + : dispose-each ( seq -- ) [ [ [ dispose ] curry [ , ] recover ] each diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 7a7ac5a97c..aebc709a9e 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -6,7 +6,10 @@ io.encodings.utf8 alien.strings continuations destructors byte-arrays accessors combinators ; IN: io.streams.c -TUPLE: c-stream handle disposed ; +TUPLE: c-stream < disposable handle ; + +: new-c-stream ( handle class -- c-stream ) + new-disposable swap >>handle ; inline M: c-stream dispose* handle>> fclose ; @@ -20,7 +23,7 @@ M: c-stream stream-seek TUPLE: c-writer < c-stream ; -: ( handle -- stream ) f c-writer boa ; +: ( handle -- stream ) c-writer new-c-stream ; M: c-writer stream-element-type drop +byte+ ; @@ -32,7 +35,7 @@ M: c-writer stream-flush dup check-disposed handle>> fflush ; TUPLE: c-reader < c-stream ; -: ( handle -- stream ) f c-reader boa ; +: ( handle -- stream ) c-reader new-c-stream ; M: c-reader stream-element-type drop +byte+ ; From bbb220f892f84be7b962e34443fd7b303579ed2b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 24 Aug 2009 19:43:19 -0500 Subject: [PATCH 18/30] make memory.piles load without auto-use --- extra/memory/piles/piles.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/memory/piles/piles.factor b/extra/memory/piles/piles.factor index 651bf2ec6c..46729c42be 100644 --- a/extra/memory/piles/piles.factor +++ b/extra/memory/piles/piles.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alien destructors kernel libc math ; +USING: accessors alien alien.c-types destructors kernel libc math ; IN: memory.piles TUPLE: pile From 197a64eaaeaa4685e232623fe8fd96206c7adf0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:19:55 -0500 Subject: [PATCH 19/30] io.streams.duplex: fix test --- basis/io/streams/duplex/duplex-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ; From 3be328056db8ab721e3a92c542568f592bf61d6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:21:03 -0500 Subject: [PATCH 20/30] libc: use central disposables mechanism to track mallocs --- basis/libc/libc-tests.factor | 4 ++-- basis/libc/libc.factor | 28 ++++++++++++------------- basis/tools/deploy/shaker/shaker.factor | 2 -- 3 files changed, 16 insertions(+), 18 deletions(-) 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/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? [ From b12bbaf7ecad3b18cb446a32faa7424f3bd9efd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:21:38 -0500 Subject: [PATCH 21/30] 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 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 + 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? + >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>> ; From 623ddfca6f8c56c985e390dbfbcee259df655648 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:22:00 -0500 Subject: [PATCH 22/30] ui.tools.operations: disposables now have a 'dispose' operation, and disposables created within a 'leaks' now have an operation which shows the continuation that created them --- basis/ui/tools/operations/operations.factor | 35 +++++++++++++++------ 1 file changed, 26 insertions(+), 9 deletions(-) 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" From adc154e06bba18e2b16ea69ac0ac1ece66bca641 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:27:22 -0500 Subject: [PATCH 23/30] destructors: already-unregistered error had the wrong content, also don't throw an error when disposing a disposable twice --- core/destructors/destructors-tests.factor | 11 ++++++++++- core/destructors/destructors.factor | 8 ++++++-- core/io/files/files-tests.factor | 8 +++++++- 3 files changed, 23 insertions(+), 4 deletions(-) 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 d306da18c4..4190cdaaf5 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -21,7 +21,7 @@ SLOT: continuation disposables get conjoin ; : unregister-disposable ( obj -- ) - disposables get 2dup key? [ already-unregistered ] unless delete-at ; + disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ; PRIVATE> @@ -49,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 From b2a1858f8f66183db1d9619158c77b0bb43a5574 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:33:27 -0500 Subject: [PATCH 24/30] Move a few more things over to new disposable protocol --- basis/checksums/openssl/openssl.factor | 8 ++++---- basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +- basis/io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +- basis/io/backend/unix/multiplexers/multiplexers.factor | 6 +++--- basis/ui/pixel-formats/pixel-formats.factor | 8 +++++--- 5 files changed, 14 insertions(+), 12 deletions(-) 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/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/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index a280ab0666..b902521079 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 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 ) From e44a0158e60fdcbc4af3aeb67273bac4f4a02a09 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:45:06 -0500 Subject: [PATCH 25/30] tools.destructors: leaks now tracks leaks globally --- basis/tools/destructors/destructors.factor | 4 ++-- core/destructors/destructors.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor index d032b5291a..c0aa35b049 100644 --- a/basis/tools/destructors/destructors.factor +++ b/basis/tools/destructors/destructors.factor @@ -44,8 +44,8 @@ PRIVATE> : leaks ( quot -- ) disposables get clone - debug-leaks? on + t debug-leaks? set-global [ [ call disposables get clone ] dip - ] [ ] [ debug-leaks? off ] cleanup + ] [ ] [ f debug-leaks? set-global ] cleanup assoc-diff (disposables.) ; inline diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 4190cdaaf5..3e57f498af 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -17,7 +17,7 @@ SYMBOL: debug-leaks? SLOT: continuation : register-disposable ( obj -- ) - debug-leaks? get [ continuation >>continuation ] when + debug-leaks? get-global [ continuation >>continuation ] when disposables get conjoin ; : unregister-disposable ( obj -- ) From 8b68a07649a23fbfc9f0a343f6d91c3a053362a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:45:19 -0500 Subject: [PATCH 26/30] ui.pixel-formats: fix screwup --- basis/ui/pixel-formats/pixel-formats.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index b902521079..f463ae2b68 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -50,7 +50,7 @@ TUPLE: pixel-format < disposable world handle ; : ( world attributes -- pixel-format ) 2dup (make-pixel-format) - [ pixel-format new swap >>handle swap >>world ] + [ pixel-format new-disposable swap >>handle swap >>world ] [ invalid-pixel-format-attributes ] ?if ; From 7b6d00a833ebd6326516b9bdd735a512018c347e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:45:46 -0500 Subject: [PATCH 27/30] alien.destructors: don't use disposable protocol, since it is common practice to 'leak' alien destructors (|Foo idiom) --- basis/alien/destructors/destructors.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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 From 29b489c892919c8f40cab2b8e9b81a1f94df939b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 20:55:24 -0500 Subject: [PATCH 28/30] io.monitors: fixes for disposable protocol --- basis/io/monitors/macosx/macosx.factor | 3 +-- basis/io/monitors/monitors.factor | 2 -- 2 files changed, 1 insertion(+), 4 deletions(-) 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) ; From c925724d7b119121c1467d5164349fbdafe2bb5c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 21:44:48 -0500 Subject: [PATCH 29/30] Improve destructors docs, fix bug where debug-leaks? wasn't being switched off --- basis/listener/listener.factor | 1 + .../tools/destructors/destructors-docs.factor | 7 ++++-- .../destructors/destructors-tests.factor | 13 +++++++++++ basis/tools/destructors/destructors.factor | 2 +- core/destructors/destructors-docs.factor | 22 +++++++++++++++++-- 5 files changed, 40 insertions(+), 5 deletions(-) create mode 100644 basis/tools/destructors/destructors-tests.factor 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/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 c0aa35b049..42d09d0ef9 100644 --- a/basis/tools/destructors/destructors.factor +++ b/basis/tools/destructors/destructors.factor @@ -47,5 +47,5 @@ PRIVATE> t debug-leaks? set-global [ [ call disposables get clone ] dip - ] [ ] [ f debug-leaks? set-global ] cleanup + ] [ f debug-leaks? set-global ] [ ] cleanup assoc-diff (disposables.) ; inline 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:" From bb51ee8d260bb6150aa1e587680274c75c9e4fc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Aug 2009 21:56:14 -0500 Subject: [PATCH 30/30] help.vocabs: 'authors' and 'tags' weren't recursing like they should've been --- basis/help/vocabs/vocabs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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 ;