diff --git a/.gitignore b/.gitignore index b80837f4e2..19ace1f500 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,7 @@ factor .gdb_history *.*.marks .*.swp +temp +logs +work +misc/wordsize \ No newline at end of file diff --git a/Makefile b/Makefile index 9776027a59..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: +default: misc/wordsize + make `./misc/target` + +help: @echo "Run 'make' with one of the following parameters:" @echo "" @echo "freebsd-x86-32" @@ -142,7 +145,8 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS - cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + ln -s Factor.app/Contents/MacOS/factor ./factor cp $(ENGINE) $(BUNDLE)/Contents/Frameworks install_name_tool \ @@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) +misc/wordsize: misc/wordsize.c + gcc misc/wordsize.c -o misc/wordsize + clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* diff --git a/README.txt b/README.txt old mode 100644 new mode 100755 index f92bfe25c7..12dade5ba1 --- a/README.txt +++ b/README.txt @@ -52,7 +52,9 @@ The Factor runtime is written in GNU C99, and is built with GNU make and gcc. Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. +3.3 or earlier. If you are using gcc 4.3, you might get an unusable +Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the +command-line arguments for make. Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of targets and build options. Then run 'make' with the appropriate target diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 19ee52b039..475cf72d28 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -87,7 +87,7 @@ $nl HELP: alien-invoke-error { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "The symbol or library could not be found." } { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } @@ -103,7 +103,7 @@ HELP: alien-invoke HELP: alien-indirect-error { $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the three inputs to " { $link alien-indirect } " is not a literal value." } } @@ -120,7 +120,7 @@ HELP: alien-indirect HELP: alien-callback-error { $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the four inputs to " { $link alien-callback } " is not a literal value." } } @@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor" { $subsection alien-invoke } "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:" { $subsection alien-indirect } -"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." -$nl -"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ; +"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ; ARTICLE: "alien-callback-gc" "Callbacks and code GC" "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 317dac803e..0369d55fb3 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -53,18 +53,11 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; -: ( path abi -- library ) f \ library construct-boa ; +: ( path abi -- library ) + over dup [ dlopen ] when \ library construct-boa ; : load-library ( name -- dll ) - library dup [ - dup library-dll [ ] [ - dup library-path dup [ - dlopen dup rot set-library-dll - ] [ - 2drop f - ] if - ] ?if - ] when ; + library library-dll ; : add-library ( name path abi -- ) swap libraries get set-at ; diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index c0c3733afa..876310cc5d 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; data-gc ; [ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out + [ callback-4 callback_test_1 ] with-string-writer ] unit-test : callback-5 diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 54348e47f9..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words @@ -213,30 +213,37 @@ TUPLE: no-such-library name ; M: no-such-library summary drop "Library not found" ; +M: no-such-library compiler-error-type + drop +linkage+ ; + : no-such-library ( name -- ) - \ no-such-library +linkage+ (inference-error) ; + \ no-such-library construct-boa + compiling-word get compiler-error ; -: (alien-invoke-dlsym) ( node -- symbol dll ) - dup alien-invoke-function - swap alien-invoke-library [ - load-library - ] [ - 2drop no-such-library - ] recover ; - -TUPLE: no-such-symbol ; +TUPLE: no-such-symbol name ; M: no-such-symbol summary drop "Symbol not found" ; -: no-such-symbol ( -- ) - \ no-such-symbol +linkage+ (inference-error) ; +M: no-such-symbol compiler-error-type + drop +linkage+ ; -: alien-invoke-dlsym ( node -- symbol dll ) - dup (alien-invoke-dlsym) 2dup dlsym [ - >r over stdcall-mangle r> 2dup dlsym - [ no-such-symbol ] unless - ] unless rot drop ; +: no-such-symbol ( name -- ) + \ no-such-symbol construct-boa + compiling-word get compiler-error ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd [ dlsym ] curry contains? + [ drop ] [ no-such-symbol ] if + ] [ + dll-path no-such-library drop + ] if ; + +: alien-invoke-dlsym ( node -- symbols dll ) + dup alien-invoke-function dup pick stdcall-mangle 2array + swap alien-invoke-library library dup [ library-dll ] when + 2dup check-dlsym ; \ alien-invoke [ ! Four literals @@ -247,8 +254,6 @@ M: no-such-symbol summary pop-literal nip over set-alien-invoke-function pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return - ! If symbol doesn't resolve, no stack effect, no compile - dup alien-invoke-dlsym 2drop ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot ! Add node to IR @@ -326,7 +331,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt ] curry + alien-callback-xt [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ @@ -362,7 +367,7 @@ TUPLE: callback-context ; ] if ; : do-callback ( quot token -- ) - init-error-handler + init-catchstack dup 2 setenv slip wait-to-return ; inline @@ -398,7 +403,7 @@ TUPLE: callback-context ; callback-unwind %unwind ; : generate-callback ( node -- ) - dup alien-callback-xt dup rot [ + dup alien-callback-xt dup [ init-templates %save-word-xt %prologue-later @@ -407,7 +412,7 @@ TUPLE: callback-context ; dup wrap-callback-quot %alien-callback %callback-return ] with-stack-frame - ] generate-1 ; + ] with-generator ; M: alien-callback generate-node end-basic-block generate-callback iterate-next ; diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor old mode 100644 new mode 100755 diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b2da0e8392..b934cd56a3 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -9,18 +9,20 @@ C-STRUCT: bar [ 36 ] [ "bar" heap-size ] unit-test [ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test -C-STRUCT: align-test - { "int" "x" } - { "double" "y" } ; +! This was actually only correct on Windows/x86: -[ 16 ] [ "align-test" heap-size ] unit-test - -cell 4 = [ - C-STRUCT: one - { "long" "a" } { "double" "b" } { "int" "c" } ; - - [ 24 ] [ "one" heap-size ] unit-test -] when +! C-STRUCT: align-test +! { "int" "x" } +! { "double" "y" } ; +! +! [ 16 ] [ "align-test" heap-size ] unit-test +! +! cell 4 = [ +! C-STRUCT: one +! { "long" "a" } { "double" "b" } { "int" "c" } ; +! +! [ 24 ] [ "one" heap-size ] unit-test +! ] when : MAX_FOOS 30 ; diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 2eabe9b0bc..716ac64c9b 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection diff } { $subsection remove-all } { $subsection substitute } +{ $subsection substitute-here } { $see-also key? } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" @@ -266,12 +267,16 @@ HELP: remove-all { $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } { $side-effects "assoc" } ; -HELP: substitute -{ $values { "assoc" assoc } { "seq" "a mutable sequence" } } -{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } +HELP: substitute-here +{ $values { "seq" "a mutable sequence" } { "assoc" assoc } } +{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } { $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." } { $side-effects "seq" } ; +HELP: substitute +{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } } +{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ; + HELP: cache { $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } { $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index d8cf01e1bd..ff0938e001 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : remove-all ( assoc seq -- subseq ) swap [ key? not ] curry subset ; -: substitute ( assoc seq -- ) - swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ; +: (substitute) + [ dupd at* [ nip ] [ drop ] if ] curry ; inline + +: substitute-here ( seq assoc -- ) + (substitute) change-each ; + +: substitute ( seq assoc -- newseq ) + (substitute) map ; : cache ( key assoc quot -- value ) 2over at [ diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..5ccde88e28 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,6 +16,14 @@ IN: bootstrap.compiler "cpu." cpu append require +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + +enable-compiler + nl "Compiling some words to speed up bootstrap..." write flush @@ -74,6 +82,4 @@ nl malloc free memcpy } compile -[ compiled-usages recompile ] recompile-hook set-global - " done" print flush diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7c12b3ea60..35dae109cf 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -36,7 +36,7 @@ IN: bootstrap.image : data-base 1024 ; inline -: userenv-size 40 ; inline +: userenv-size 64 ; inline : header-size 10 ; inline @@ -416,7 +416,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - [ (write-image) ] with-stream ; + [ (write-image) ] with-file-writer ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 66ede8b054..f3f233ea0b 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,7 +30,10 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set -[ drop ] recompile-hook set + +! Trivial recompile hook. We don't want to touch the code heap +! during stage1 bootstrap, it would just waste time. +[ drop { } ] recompile-hook set call call @@ -98,7 +101,7 @@ H{ } clone update-map set [ over "type" word-prop dup \ tag-mask get < \ tag \ type ? , , \ eq? , - ] [ ] make define-predicate ; + ] [ ] make define-predicate* ; : register-builtin ( class -- ) dup "type" word-prop builtins get set-nth ; @@ -646,6 +649,7 @@ builtins get num-tags get tail f union-class define-class { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } + { "dll-valid?" "alien" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 4f5bf6d69e..0e038d0a10 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.stage1 USING: arrays debugger generic hashtables io assocs kernel.private kernel math memory namespaces parser prettyprint sequences vectors words system splitting init io.files bootstrap.image bootstrap.image.private vocabs -vocabs.loader system ; +vocabs.loader system debugger continuations ; { "resource:core" } vocab-roots set @@ -31,6 +31,7 @@ vocabs.loader system ; "libc" require "io.streams.c" require + "io.thread" require "vocabs.loader" require "syntax" require @@ -39,7 +40,14 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" dup resource-exists? [ - run-file + [ run-file ] + [ + :c + dup print-error flush + "listener" vocab + [ restarts. vocab-main execute ] + [ die ] if* + ] recover ] [ "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 9dd56c6524..63b5726ad7 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -29,9 +29,7 @@ SYMBOL: bootstrap-time : compile-remaining ( -- ) "Compiling remaining words..." print flush - vocabs [ - words "compile" "compiler" lookup execute - ] each ; + vocabs [ words [ compiled? not ] subset compile ] each ; : count-words ( pred -- ) all-words swap subset length number>string write ; @@ -53,65 +51,60 @@ SYMBOL: bootstrap-time ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep -[ - ! We time bootstrap - millis >r - default-image-name "output-image" set-global +! We time bootstrap +millis >r - "math help compiler tools ui ui.tools io" "include" set-global - "" "exclude" set-global +default-image-name "output-image" set-global - parse-command-line +"math help handbook compiler tools ui ui.tools io" "include" set-global +"" "exclude" set-global - "-no-crossref" cli-args member? [ do-crossref ] unless +parse-command-line - ! Set dll paths - wince? [ "windows.ce" require ] when - winnt? [ "windows.nt" require ] when +"-no-crossref" cli-args member? [ do-crossref ] unless - "deploy-vocab" get [ - "stage2: deployment mode" print - ] [ - "listener" require - "none" require - ] if +! Set dll paths +wince? [ "windows.ce" require ] when +winnt? [ "windows.nt" require ] when - [ - load-components - - run-bootstrap-init - - "bootstrap.compiler" vocab [ - compile-remaining - ] when - ] with-compiler-errors - :errors - - f error set-global - f error-continuation set-global - - "deploy-vocab" get [ - "tools.deploy.shaker" run - ] [ - [ - boot - do-init-hooks - [ - parse-command-line - run-user-init - "run" get run - stdio get [ stream-flush ] when* - ] [ print-error 1 exit ] recover - ] set-boot-quot - - millis r> - dup bootstrap-time set-global - print-report - - "output-image" get resource-path save-image-and-exit - ] if +"deploy-vocab" get [ + "stage2: deployment mode" print ] [ - print-error :c restarts. - "listener" vocab-main execute - 1 exit -] recover + "listener" require + "none" require +] if + +[ + load-components + + run-bootstrap-init + + "bootstrap.compiler" vocab [ + compile-remaining + ] when +] with-compiler-errors +:errors + +f error set-global +f error-continuation set-global + +"deploy-vocab" get [ + "tools.deploy.shaker" run +] [ + [ + boot + do-init-hooks + [ + parse-command-line + run-user-init + "run" get run + stdio get [ stream-flush ] when* + ] [ print-error 1 exit ] recover + ] set-boot-quot + + millis r> - dup bootstrap-time set-global + print-report + + "output-image" get resource-path save-image-and-exit +] if diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor new file mode 100755 index 0000000000..b3b91d06d9 --- /dev/null +++ b/core/boxes/boxes-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax kernel ; +IN: boxes + +HELP: box +{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ; + +HELP: +{ $values { "box" box } } +{ $description "Creates a new empty box." } ; + +HELP: >box +{ $values { "value" object } { "box" box } } +{ $description "Stores a value into a box." } +{ $errors "Throws an error if the box is full." } ; + +HELP: box> +{ $values { "box" box } { "value" "the value of the box" } } +{ $description "Removes a value from a box." } +{ $errors "Throws an error if the box is empty." } ; + +HELP: ?box +{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; + +ARTICLE: "boxes" "Boxes" +"A " { $emphasis "box" } " is a container which can either be empty or hold a single value." +{ $subsection box } +"Creating an empty box:" +{ $subsection } +"Testing if a box is full:" +{ $subsection box-full? } +"Storing a value and removing a value from a box:" +{ $subsection >box } +{ $subsection box> } +"Safely removing a value:" +{ $subsection ?box } ; + +ABOUT: "boxes" diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor new file mode 100755 index 0000000000..66ee5247ec --- /dev/null +++ b/core/boxes/boxes-tests.factor @@ -0,0 +1,24 @@ +IN: temporary +USING: boxes namespaces tools.test ; + +[ ] [ "b" set ] unit-test + +[ ] [ 3 "b" get >box ] unit-test + +[ t ] [ "b" get box-full? ] unit-test + +[ 4 "b" >box ] must-fail + +[ 3 ] [ "b" get box> ] unit-test + +[ f ] [ "b" get box-full? ] unit-test + +[ "b" get box> ] must-fail + +[ f f ] [ "b" get ?box ] unit-test + +[ ] [ 12 "b" get >box ] unit-test + +[ 12 t ] [ "b" get ?box ] unit-test + +[ f ] [ "b" get box-full? ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor new file mode 100755 index 0000000000..8197e57969 --- /dev/null +++ b/core/boxes/boxes.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: boxes + +TUPLE: box value full? ; + +: ( -- box ) box construct-empty ; + +: >box ( value box -- ) + dup box-full? [ "Box already has a value" throw ] when + t over set-box-full? + set-box-value ; + +: box> ( box -- value ) + dup box-full? [ "Box empty" throw ] unless + dup box-value f pick set-box-value + f rot set-box-full? ; + +: ?box ( box -- value/f ? ) + dup box-full? [ box> t ] [ drop f f ] if ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 859b6a95d5..56dda6f904 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -119,7 +119,7 @@ HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; -HELP: define-predicate +HELP: define-predicate* { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } { $description "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" @@ -132,6 +132,13 @@ HELP: define-predicate } $low-level-note ; +HELP: define-predicate +{ $values { "class" class } { "quot" "a quotation" } } +{ $description + "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "." +} +$low-level-note ; + HELP: superclass { $values { "class" class } { "super" class } } { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c7024a7490..103c4eed09 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -63,7 +63,7 @@ UNION: bah fixnum alien ; ! Test generic see and parsing [ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] -[ [ \ bah see ] string-out ] unit-test +[ [ \ bah see ] with-string-writer ] unit-test ! Test redefinition of classes UNION: union-1 fixnum float ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 345676e106..48ddb2adf5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -31,13 +31,16 @@ PREDICATE: class tuple-class PREDICATE: word predicate "predicating" word-prop >boolean ; -: define-predicate ( class predicate quot -- ) +: define-predicate* ( class predicate quot -- ) over [ dupd predicate-effect define-declared 2dup 1quotation "predicate" set-word-prop swap "predicating" set-word-prop - ] [ - 3drop + ] [ 3drop ] if ; + +: define-predicate ( class quot -- ) + over "forgotten" word-prop [ 2drop ] [ + >r dup predicate-word r> define-predicate* ] if ; : superclass ( class -- super ) @@ -252,8 +255,7 @@ PRIVATE> : (define-class) ( word props -- ) over reset-class - over reset-generic - over define-symbol + over deferred? [ over define-symbol ] when >r dup word-props r> union over set-word-props t "class" set-word-prop ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor old mode 100644 new mode 100755 index a7270869c5..6d1c727ee2 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -16,7 +16,7 @@ PREDICATE: class predicate-class : define-predicate-class ( superclass class definition -- ) >r dup f roll predicate-class define-class r> dupd "predicate-definition" set-word-prop - dup predicate-word over predicate-quot define-predicate ; + dup predicate-quot define-predicate ; M: predicate-class reset-class { diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 332903d36b..dcc05e8160 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,9 +31,7 @@ PREDICATE: class union-class ] if ; : define-union-predicate ( class -- ) - dup predicate-word - over members union-predicate-quot - define-predicate ; + dup members union-predicate-quot define-predicate ; M: union-class update-predicate define-union-predicate ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index d91c920def..5b87297b0c 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" { $subsection cond>quot } { $subsection case>quot } -{ $subsection alist>quot } -"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:" -{ $subsection hash-case>quot } -{ $subsection distribute-buckets } -{ $subsection hash-dispatch-quot } ; +{ $subsection alist>quot } ; ARTICLE: "combinators" "Additional combinators" "The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":" @@ -104,19 +100,17 @@ HELP: case>quot { $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } } { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." $nl -"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ; +"This word uses three strategies:" +{ $list + "If the assoc only has a few keys, a linear search is generated." + { "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." } + "Otherwise, an open-coded hashtable dispatch is generated." +} } ; HELP: distribute-buckets { $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } } { $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." } -{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ; - -HELP: hash-case>quot -{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } } -{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." -$nl -"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." } -{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ; +{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ; HELP: dispatch ( n array -- ) { $values { "n" "a fixnum" } { "array" "an array of quotations" } } diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 index 3cefda7f71..ce8e180867 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -69,3 +69,10 @@ namespaces combinators words ; ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test + +[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test +[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test +[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test +[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test +[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test +[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0ba8b583be..ffd1576e6e 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: combinators USING: arrays sequences sequences.private math.private -kernel kernel.private math assocs quotations vectors ; +kernel kernel.private math assocs quotations vectors +hashtables sorting ; TUPLE: no-cond ; @@ -31,16 +32,24 @@ TUPLE: no-case ; : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline +! These go here, not in sequences and hashtables, since those +! two depend on combinators M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ; +M: hashtable hashcode* + [ + dup assoc-size 1 number= + [ assoc-hashcode ] [ nip assoc-size ] if + ] recursive-hashcode ; + : alist>quot ( default assoc -- quot ) [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) reverse [ no-cond ] swap alist>quot ; -: case>quot ( default assoc -- quot ) +: linear-case-quot ( default assoc -- quot ) [ >r [ dupd = ] curry r> \ drop add* ] assoc-map alist>quot ; @@ -63,20 +72,50 @@ M: sequence hashcode* : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets - [ case>quot ] with map ; + [ linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) [ length 1- [ fixnum-bitand ] curry ] keep [ dispatch ] curry append ; -: hash-case>quot ( default assoc -- quot ) +: hash-case-quot ( default assoc -- quot ) + hash-case-table hash-dispatch-quot + [ dup hashcode >fixnum ] swap append ; + +: contiguous-range? ( keys -- from to ? ) + dup [ fixnum? ] all? [ + dup all-unique? [ + dup infimum over supremum + [ - swap prune length + 1 = ] 2keep rot + ] [ + drop f f f + ] if + ] [ + drop f f f + ] if ; + +: dispatch-case ( value from to default array -- ) + >r >r 3dup between? [ + drop - >fixnum r> drop r> dispatch + ] [ + 2drop r> call r> drop + ] if ; inline + +: dispatch-case-quot ( default assoc from to -- quot ) + -roll -roll sort-keys values [ >quotation ] map + [ dispatch-case ] 2curry 2curry ; + +: case>quot ( default assoc -- quot ) dup empty? [ drop ] [ dup length 4 <= [ - case>quot + linear-case-quot ] [ - hash-case-table hash-dispatch-quot - [ dup hashcode >fixnum ] swap append + dup keys contiguous-range? [ + dispatch-case-quot + ] [ + 2drop hash-case-quot + ] if ] if ] if ; diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 17e6938a0c..7196a4b4fb 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -1,18 +1,14 @@ USING: generator help.markup help.syntax words io parser -assocs words.private sequences ; +assocs words.private sequences compiler.units ; IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." $nl -"The main entry points to the optimizing compiler:" -{ $subsection compile } -{ $subsection recompile } -{ $subsection recompile-all } +"The main entry point to the optimizing compiler:" +{ $subsection optimized-recompile-hook } "Removing a word's optimized definition:" -{ $subsection decompile } -"The optimizing compiler can also compile and call a single quotation:" -{ $subsection compile-call } ; +{ $subsection decompile } ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" @@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler" ABOUT: "compiler" -HELP: compile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Ignores words which are already compiled." } ; - -HELP: recompile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ; - -HELP: compile-call -{ $values { "quot" "a quotation" } } -{ $description "Compiles and runs a quotation." } -{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; - -HELP: recompile-all -{ $description "Recompiles all words." } ; - HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; @@ -50,3 +30,8 @@ HELP: (compile) { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; + +HELP: optimized-recompile-hook +{ $values { "words" "a sequence of words" } { "alist" "an association list" } } +{ $description "Compile a set of words." } +{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 2674734483..111d84cde0 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger math.parser prettyprint words compiler.units continuations vocabs assocs alien.compiler dlists optimizer definitions math compiler.errors threads graphs -generic ; +generic inference ; IN: compiler -: compiled-usages ( words -- seq ) - [ [ dup ] H{ } map>assoc dup ] keep [ - compiled-usage [ nip +inlined+ eq? ] assoc-subset update - ] with each keys ; - : ripple-up ( word -- ) compiled-usage [ drop queue-compile ] assoc-each ; @@ -24,13 +19,12 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> - f pick compiler-error over compiled-unxref over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ - dup word-dataflow >r swap dup r> optimize generate + [ word-dataflow optimize ] keep dup generate ] computing-dependencies ; : compile-failed ( word error -- ) @@ -38,6 +32,7 @@ IN: compiler swap compiler-error ; : (compile) ( word -- ) + f over compiler-error [ dup compile-succeeded finish-compile ] [ dupd compile-failed f save-effect ] recover ; @@ -49,25 +44,17 @@ IN: compiler compile-loop ] if ; -: recompile ( words -- ) +: decompile ( word -- ) + f 2array 1array t modify-code-heap ; + +: optimized-recompile-hook ( words -- alist ) [ H{ } clone compile-queue set H{ } clone compiled set [ queue-compile ] each compile-queue get compile-loop - compiled get >alist modify-code-heap - ] with-scope ; inline - -: compile ( words -- ) - [ compiled? not ] subset recompile ; - -: compile-call ( quot -- ) - H{ } clone changed-words - [ define-temp dup 1array compile ] with-variable - execute ; + compiled get >alist + ] with-scope ; : recompile-all ( -- ) - [ all-words recompile ] with-compiler-errors ; - -: decompile ( word -- ) - f 2array 1array modify-code-heap ; + forget-errors all-words compile ; diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 77ac01e101..982b3cfb75 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,5 +1,5 @@ -USING: tools.test compiler quotations math kernel sequences -assocs namespaces ; +USING: tools.test quotations math kernel sequences +assocs namespaces compiler.units ; IN: temporary [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 10d3baea9b..11470f7102 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -1,5 +1,5 @@ IN: temporary -USING: compiler kernel kernel.private memory math +USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 5dfe447443..d1e6f7abf4 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,10 +1,11 @@ IN: temporary -USING: arrays compiler kernel kernel.private math math.constants -math.private sequences strings tools.test words continuations -sequences.private hashtables.private byte-arrays strings.private -system random layouts vectors.private sbufs.private -strings.private slots.private alien alien.accessors -alien.c-types alien.syntax namespaces libc sequences.private ; +USING: arrays compiler.units kernel kernel.private math +math.constants math.private sequences strings tools.test words +continuations sequences.private hashtables.private byte-arrays +strings.private system random layouts vectors.private +sbufs.private strings.private slots.private alien +alien.accessors alien.c-types alien.syntax namespaces libc +sequences.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 1ed43120d3..7f23e28bec 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,4 +1,4 @@ -USING: compiler tools.test kernel kernel.private +USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory ; IN: temporary @@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ; [ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test + +! Regression +[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 71c95b1b61..137d86b489 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -1,7 +1,7 @@ IN: temporary USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private -words splitting ; +words splitting sorting ; : symbolic-stack-trace ( -- newseq ) error-continuation get continuation-call callstack>array @@ -31,9 +31,9 @@ words splitting ; \ > stack-trace-contains? ] unit-test -: quux [ t [ "hi" throw ] when ] times ; +: quux { 1 2 3 } [ "hi" throw ] sort ; [ t ] [ [ 10 quux ] ignore-errors - \ (each-integer) stack-trace-contains? + \ sort stack-trace-contains? ] unit-test diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index e518d2de8a..13d834a489 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ; [ [ ] [ init-templates ] unit-test - [ ] [ init-generator ] unit-test + H{ } clone compiled set + + [ ] [ gensym gensym begin-compiling ] unit-test [ t ] [ [ end-basic-block ] { } make empty? ] unit-test diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 74e5ab80a4..4be700f221 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts -words definitions compiler.units ; +words definitions compiler.units io combinators ; IN: temporary ! Oops! @@ -191,3 +191,18 @@ TUPLE: my-tuple ; 2 1 [ 2dup fixnum< [ >r die r> ] when ] compile-call ] unit-test + +! Regression +: a-dummy drop "hi" print ; + +[ ] [ + 1 [ + dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [ + drop - >fixnum { + [ a-dummy ] + [ a-dummy ] + [ a-dummy ] + } dispatch + ] [ 2drop no-case ] if + ] compile-call +] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index a23b6739ad..7acd599cb8 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ IN: temporary -USING: kernel tools.test compiler ; +USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 99124d40ae..d30c5457d5 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- ) { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; + +HELP: compile +{ $values { "seq" "a sequence of words" } } +{ $description "Compiles a set of words." } ; + +HELP: compile-call +{ $values { "quot" "a quotation" } } +{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 242ed9854a..9849ddca7d 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables ; +vocabs definitions hashtables init ; IN: compiler.units SYMBOL: old-definitions @@ -37,10 +37,11 @@ SYMBOL: recompile-hook SYMBOL: definition-observers -definition-observers global [ V{ } like ] change-at - GENERIC: definitions-changed ( assoc obj -- ) +[ V{ } clone definition-observers set-global ] +"compiler.units" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; @@ -63,20 +64,46 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-words get update dup dup changed-vocabs update ; +: compile ( words -- ) + recompile-hook get call + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + +SYMBOL: post-compile-tasks + +: after-compilation ( quot -- ) + post-compile-tasks get push ; + +: call-recompile-hook ( -- ) + changed-words get keys + compiled-usages recompile-hook get call ; + +: call-post-compile-tasks ( -- ) + post-compile-tasks get [ call ] each ; + : finish-compilation-unit ( -- ) - changed-words get keys recompile-hook get call + call-recompile-hook + call-post-compile-tasks + dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set H{ } clone forgotten-definitions set + V{ } clone post-compile-tasks set new-definitions set old-definitions set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline +: compile-call ( quot -- ) + [ define-temp ] with-compilation-unit execute ; + +: default-recompile-hook ( words -- alist ) + [ f ] { } map>assoc ; + recompile-hook global -[ [ [ f ] { } map>assoc modify-code-heap ] or ] +[ [ default-recompile-hook ] or ] change-at diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7cf15394ef..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -threads assocs words quotations ; +assocs words quotations ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -23,9 +23,10 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"Two words for establishing an error handler:" +"Words for establishing an error handler:" { $subsection cleanup } { $subsection recover } +{ $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -44,11 +45,7 @@ ARTICLE: "continuations.private" "Continuation implementation details" { $subsection namestack } { $subsection set-namestack } { $subsection catchstack } -{ $subsection set-catchstack } -"The continuations implementation has hooks for single-steppers:" -{ $subsection walker-hook } -{ $subsection set-walker-hook } -{ $subsection (continue-with) } ; +{ $subsection set-catchstack } ; ARTICLE: "continuations" "Continuations" "At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." @@ -110,10 +107,6 @@ HELP: callcc1 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; -HELP: (continue-with) -{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } -{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ; - HELP: continue { $values { "continuation" continuation } } { $description "Resumes a continuation reified by " { $link callcc0 } "." } ; @@ -156,6 +149,10 @@ HELP: recover { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; +HELP: ignore-errors +{ $values { "try" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } @@ -196,9 +193,3 @@ HELP: save-error { $values { "error" "an error" } } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } $low-level-note ; - -HELP: init-error-handler -{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; - -HELP: break -{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 81f78f491d..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -91,14 +94,8 @@ C: continuation PRIVATE> -: set-walker-hook ( quot -- ) 3 setenv ; inline - -: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline - : continue-with ( obj continuation -- ) - [ - walker-hook [ >r 2array r> ] when* (continue-with) - ] 2 (throw) ; + [ (continue-with) ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; @@ -113,13 +110,22 @@ GENERIC: compute-restarts ( error -- seq ) PRIVATE> +SYMBOL: thread-error-hook + : rethrow ( error -- * ) - catchstack* empty? [ die ] when - dup save-error c> continue-with ; + dup save-error + catchstack* empty? [ + thread-error-hook get-global + [ 1 (throw) ] [ die ] if* + ] when + c> continue-with ; : recover ( try recovery -- ) >r [ swap >c call c> drop ] curry r> ifcc ; inline +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry recover r> call ; inline @@ -166,34 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - - -! Debugging support -: with-walker-hook ( continuation -- ) - [ swap set-walker-hook (continue) ] curry callcc1 ; - -SYMBOL: break-hook - -: break ( -- ) - continuation callstack - over set-continuation-call - walker-hook [ (continue-with) ] [ break-hook get call ] if* ; - -GENERIC: (step-into) ( obj -- ) - -M: wrapper (step-into) wrapped break ; -M: object (step-into) break ; -M: callable (step-into) \ break add* break ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4bb10b23a2..cd6c8b61f7 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke compiler-backend ( library function -- ) +HOOK: %alien-invoke compiler-backend ( function library -- ) HOOK: %cleanup compiler-backend ( alien-node -- ) diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ecae55e69a..649cfbabab 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system alien.compiler combinators command-line -compiler io vocabs.loader ; +compiler compiler.units io vocabs.loader ; IN: cpu.x86.32 PREDICATE: x86-backend x86-32-backend @@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush - [ sse2? ] compile-call [ + [ optimized-recompile-hook ] recompile-hook [ + [ sse2? ] compile-call + ] with-variable + [ " - yes" print "cpu.x86.sse2" require ] [ diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index b754856ee4..5e8b6df34a 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,6 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system ; +help generic.standard continuations system debugger.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" @@ -80,9 +80,6 @@ HELP: print-error HELP: restarts. { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ; -HELP: debug-help -{ $description "Print a synopsis of useful debugger words." } ; - HELP: error-hook { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." } { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ; @@ -169,3 +166,6 @@ HELP: depth HELP: assert-depth { $values { "quot" "a quotation" } } { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; + +HELP: init-debugger +{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ; diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor new file mode 100755 index 0000000000..31c3e8a762 --- /dev/null +++ b/core/debugger/debugger-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: debugger kernel continuations tools.test ; + +[ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 53f3387d85..40bcbe78b1 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard ; +generic.standard vocabs threads threads.private init +kernel.private libc ; IN: debugger GENERIC: error. ( error -- ) @@ -31,6 +32,9 @@ M: string error. print ; : :get ( variable -- value ) error-continuation get continuation-name assoc-stack ; +: :vars ( -- ) + error-continuation get continuation-name namestack. ; + : :res ( n -- ) 1- restarts get-global nth f restarts set-global restart ; @@ -54,19 +58,6 @@ M: string error. print ; dup length [ restart. ] 2each ] if ; -: debug-help ( -- ) - nl - "Debugger commands:" print - nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print - ":edit - jump to source location (parse errors only)" print - - ":get ( var -- value ) accesses variables at time of the error" print - flush ; - : print-error ( error -- ) [ error. flush ] curry [ global [ "Error in print-error!" print drop ] bind ] @@ -74,7 +65,12 @@ M: string error. print ; SYMBOL: error-hook -[ print-error restarts. debug-help ] error-hook set-global +[ + print-error + restarts. + nl + "Type :help for debugging help." print flush +] error-hook set-global : try ( quot -- ) [ error-hook get call ] recover ; @@ -254,3 +250,52 @@ M: no-compilation-unit error. "Attempting to define " write no-compilation-unit-definition pprint " outside of a compilation unit" print ; + +M: no-vocab summary + drop "Vocabulary does not exist" ; + +M: check-ptr summary + drop "Memory allocation failed" ; + +M: double-free summary + drop "Free failed since memory is not allocated" ; + +M: realloc-error summary + drop "Memory reallocation failed" ; + +: error-in-thread. ( -- ) + error-thread get-global + "Error in thread " write + [ + dup thread-id # + " (" % dup thread-name % + ", " % dup thread-quot unparse-short % ")" % + ] "" make swap write-object ":" print nl ; + +! Hooks +M: thread error-in-thread ( error thread -- ) + initial-thread get-global eq? [ + die drop + ] [ + global [ + error-in-thread. print-error flush + ] bind + ] if ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index ad261df7d4..01f9643cdd 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -43,7 +43,7 @@ M: object uses drop f ; : xref ( defspec -- ) dup uses crossref get add-vertex ; -: usage ( defspec -- seq ) crossref get at keys ; +: usage ( defspec -- seq ) \ f or crossref get at keys ; GENERIC: redefined* ( defspec -- ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 17c0c64bf1..3ee93ba4a5 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -111,7 +111,8 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; : string>symbol ( str -- alien ) - wince? [ string>u16-alien ] [ string>char-alien ] if ; + [ wince? [ string>u16-alien ] [ string>char-alien ] if ] + over string? [ call ] [ map ] if ; : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; @@ -140,17 +141,19 @@ SYMBOL: literal-table V{ } clone relocation-table set V{ } clone label-table set ; -: generate-labels ( -- labels ) - label-table get [ +: resolve-labels ( labels -- labels' ) + [ first3 label-offset [ "Unresolved label" throw ] unless* 3array ] map concat ; -: fixup ( code -- relocation-table label-table code ) +: fixup ( code -- literals relocation labels code ) [ init-fixup dup stack-frame-size swap [ fixup* ] each drop + + literal-table get >array relocation-table get >array - generate-labels + label-table get resolve-labels ] { } make ; diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 029749180e..4473df7277 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -22,34 +22,35 @@ HELP: compiled { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; HELP: compiling-word -{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ; +{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ; HELP: compiling-label -{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ; +{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ; HELP: compiled-stack-traces? { $values { "?" "a boolean" } } { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ; HELP: literal-table -{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ; +{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ; -HELP: init-generator +HELP: begin-compiling +{ $values { "word" word } { "label" word } } { $description "Prepares to generate machine code for a word." } ; -HELP: generate-1 -{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } } +HELP: with-generator +{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } } { $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ; HELP: generate-node { $values { "node" "a dataflow node" } { "next" "a dataflow node" } } { $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." } -{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ; +{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ; HELP: generate-nodes { $values { "node" "a dataflow node" } } { $description "Recursively generate machine code for a dataflow graph." } -{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ; +{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ; HELP: generate { $values { "word" word } { "label" word } { "node" "a dataflow node" } } diff --git a/core/generator/generator.factor b/core/generator/generator.factor index d8164fdce7..3514947e3d 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -11,12 +11,6 @@ IN: generator SYMBOL: compile-queue SYMBOL: compiled -: begin-compiling ( word -- ) - f swap compiled get set-at ; - -: finish-compiling ( word literals relocation labels code -- ) - 4array swap compiled get set-at ; - : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } @@ -32,24 +26,31 @@ SYMBOL: compiling-word SYMBOL: compiling-label +SYMBOL: compiling-loops + ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start : compiled-stack-traces? ( -- ? ) 36 getenv ; -: init-generator ( -- ) +: begin-compiling ( word label -- ) + H{ } clone compiling-loops set + compiling-label set + compiling-word set compiled-stack-traces? - compiling-word get f ? - 1vector literal-table set ; + compiling-word get f ? + 1vector literal-table set + f compiling-word get compiled get set-at ; -: generate-1 ( word label node quot -- ) - pick begin-compiling [ - roll compiling-word set - pick compiling-label set - init-generator - call - literal-table get >array - ] { } make fixup finish-compiling ; +: finish-compiling ( literals relocation labels code -- ) + 4array compiling-label get compiled get set-at ; + +: with-generator ( node word label quot -- ) + [ + >r begin-compiling r> + { } make fixup + finish-compiling + ] with-scope ; inline GENERIC: generate-node ( node -- next ) @@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next ) %prologue-later current-label-start define-label current-label-start resolve-label ; - -: generate ( word label node -- ) + +: generate ( node word label -- ) [ init-generate-nodes [ generate-nodes ] with-node-iterator - ] generate-1 ; + ] with-generator ; : word-dataflow ( word -- effect dataflow ) [ @@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next ) : if-intrinsics ( #call -- quot ) node-param "if-intrinsics" word-prop ; -DEFER: #terminal? - -PREDICATE: #merge #terminal-merge node-successor #terminal? ; - -PREDICATE: #values #terminal-values node-successor #terminal? ; - -PREDICATE: #call #terminal-call - dup node-successor #if? - over node-successor node-successor #terminal? and - swap if-intrinsics and ; - -UNION: #terminal - POSTPONE: f #return #terminal-values #terminal-merge ; - -: tail-call? ( -- ? ) - node-stack get [ - dup #terminal-call? swap node-successor #terminal? or - ] all? ; - ! node M: node generate-node drop iterate-next ; @@ -112,20 +94,34 @@ M: node generate-node drop iterate-next ; : generate-call ( label -- next ) dup maybe-compile end-basic-block - tail-call? [ - %jump f + dup compiling-loops get at [ + %jump-label f ] [ - 0 frame-required - %call - iterate-next - ] if ; + tail-call? [ + %jump f + ] [ + 0 frame-required + %call + iterate-next + ] if + ] ?if ; ! #label M: #label generate-node dup node-param generate-call >r - dup #label-word over node-param rot node-child generate + dup node-child over #label-word rot node-param generate r> ; +! #loop +: compiling-loop ( word -- ) +