From 8806a0b18b446c949c274b608b7f2d00b1d6861b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 15 Apr 2009 16:12:31 -0700 Subject: [PATCH 01/83] Make fuel auto-use the existing using in fuel-debug--uses-for-file. --- extra/fuel/fuel.factor | 28 +++++++++++++++++++++++++--- misc/fuel/fuel-debug-uses.el | 12 +++++++++--- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..a8c2adc3e1 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs compiler.units fuel.eval fuel.help fuel.remote fuel.xref -help.topics io.pathnames kernel namespaces parser sequences -tools.scaffold vocabs.loader ; +USING: accessors assocs compiler.units continuations fuel.eval fuel.help +fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser +sequences tools.scaffold vocabs.loader ; IN: fuel @@ -28,6 +28,24 @@ IN: fuel > [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; + +: get-restart-vocab ( restart -- vocab ) + [ "Use the " length ] dip + name>> [ length " vocabulary" length - ] keep + subseq ; + +: is-suggested-restart ( restart -- ? ) + dup is-use-restart [ + get-restart-vocab :uses-suggestions get member? + ] [ drop f ] if ; + +: try-suggested-restarts ( -- ) + restarts get [ is-suggested-restart ] filter + dup length 1 = [ first restart ] [ drop ] if ; : fuel-set-use-hook ( -- ) [ amended-use get clone :uses prefix fuel-eval-set-result ] @@ -38,6 +56,10 @@ SYMBOL: :uses PRIVATE> +: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) + [ :uses-suggestions set ] dip + [ try-suggested-restarts rethrow ] recover ; + : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 4842f960d1..8b25744011 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -88,9 +88,16 @@ fuel-debug--uses nil fuel-debug--uses-restarts nil)) +(defun fuel-debug--current-usings (file) + (with-current-buffer (find-file-noselect file) + (sort (fuel-syntax--find-usings t) 'string<))) + (defun fuel-debug--uses-for-file (file) (let* ((lines (fuel-debug--file-lines file)) - (cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t))) + (old-usings (fuel-debug--current-usings file)) + (cmd `(:fuel ((V{ ,@old-usings } + [ V{ ,@lines } fuel-get-uses ] + fuel-use-suggested-vocabs)) t t))) (fuel-debug--uses-prepare file) (fuel--with-popup (fuel-debug--uses-buffer) (insert "Asking Factor. Please, wait ...\n") @@ -105,8 +112,7 @@ (defun fuel-debug--uses-display (uses) (let* ((inhibit-read-only t) - (old (with-current-buffer (find-file-noselect fuel-debug--uses-file) - (sort (fuel-syntax--find-usings t) 'string<))) + (old (fuel-debug--current-usings fuel-debug--uses-file)) (new (sort uses 'string<))) (erase-buffer) (fuel-debug--uses-insert-title) From af7ecb16cfd617c78c4987895b96a52328879f27 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 14:52:24 -0700 Subject: [PATCH 02/83] Determine restart vocab thru obj>> instead of error string --- extra/fuel/fuel.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 3c623212b0..12eb5bdbfc 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs compiler.units continuations fuel.eval fuel.help -fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser -sequences tools.scaffold vocabs.loader ; +fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser +sequences tools.scaffold vocabs.loader words ; IN: fuel @@ -33,10 +33,8 @@ SYMBOL: :uses-suggestions : is-use-restart ( restart -- ? ) name>> [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; -: get-restart-vocab ( restart -- vocab ) - [ "Use the " length ] dip - name>> [ length " vocabulary" length - ] keep - subseq ; +: get-restart-vocab ( restart -- vocab/f ) + obj>> dup word? [ vocabulary>> ] [ drop f ] if ; : is-suggested-restart ( restart -- ? ) dup is-use-restart [ @@ -56,9 +54,9 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) [ :uses-suggestions set ] dip - [ try-suggested-restarts rethrow ] recover ; + [ try-suggested-restarts rethrow ] recover ; inline : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline From 18b5090892e20b5016affc51846340d9e3e52c00 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 19:57:35 -0700 Subject: [PATCH 03/83] Add tests for auto-USING selection --- extra/fuel/fuel-tests.factor | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/fuel/fuel-tests.factor diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..a0cab888e8 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Nicholas Seckar. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations eval fuel fuel.private namespaces tools.test words ; +IN: fuel.tests + +: fake-continuation ( -- continuation ) + f f f "fake" f ; + +: make-uses-restart ( -- restart ) + "Use the words vocabulary" \ word? + fake-continuation ; + +: make-defer-restart ( -- restart ) + "Defer word in current vocabulary" f + fake-continuation ; + +{ f } [ make-defer-restart is-use-restart ] unit-test +{ t } [ make-uses-restart is-use-restart ] unit-test + +{ "words" } [ make-uses-restart get-restart-vocab ] unit-test + +{ f } [ make-defer-restart is-suggested-restart ] unit-test +{ f } [ make-uses-restart is-suggested-restart ] unit-test +{ f } [ { "io" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test +{ t } [ { "words" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test + +{ } [ + { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs +] unit-test From 47064cd1af6c1ddc6448928acea86f371e293840 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 22 Apr 2009 15:40:17 -0700 Subject: [PATCH 04/83] Fix stack effect of fuel-use-suggested-vocabs --- extra/fuel/fuel.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 12eb5bdbfc..a9ed17877e 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -54,7 +54,7 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot -- ... ) [ :uses-suggestions set ] dip [ try-suggested-restarts rethrow ] recover ; inline From e4055005ea0cbdfda801f507761fb1d1652f4147 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:03:38 +0200 Subject: [PATCH 05/83] FUEL: Fixes for string highlighting. --- misc/fuel/fuel-syntax.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 6b646511ca..61aa2b7cdd 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -241,18 +241,17 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(;; Comments - ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) - ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) - ;; Strings and chars - ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" - (1 "w") (2 "\"") (4 "\"")) - ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w")) - ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" - (3 "\"") (5 "\"")) - ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\"")) + `(;; Strings and chars ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) + ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)?\\(\"\\)\\(\\([^\n\r\f\"\\]\\|\\\\.\\)*\\)\\(\"\\)" + (3 "\"") (6 "\"")) + ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" + (1 "w") (2 "b")) + ("\\(CHAR:\\|\\\\\\) \\(\\w\\|!\\)\\( \\|$\\)" (2 "w")) + ;; Comments + ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ;; postpone ("\\_b")) ;; Multiline constructs From 9b19b341268834751631f1ae69ce870672b33046 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:15:20 +0200 Subject: [PATCH 06/83] FUEL: Fix for C-cC-eC-l (make factor command ( -- )). --- misc/fuel/fuel-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index aa9a7d944e..0186392f34 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -140,7 +140,7 @@ for details." (interactive) (message "Loading all vocabularies in USING: form ...") (let ((err (fuel-eval--retort-error - (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (fuel-eval--send/wait '(:fuel* (t .) t :usings) 120000)))) (message (if err "Warning: some vocabularies failed to load" "All vocabularies loaded")))) From 8c5b0373a83955d0f94b86055c6a3623145d8e79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 15:31:06 -0500 Subject: [PATCH 07/83] Working on new method dispatch system --- Makefile | 3 +- .../known-words/known-words.factor | 3 + core/bootstrap/primitives.factor | 2 + core/generic/standard/compiler/authors.txt | 1 + .../generic/standard/compiler/compiler.factor | 174 ++++++++++++++++++ vm/data_heap.c | 2 +- vm/dispatch.c | 108 +++++++++++ vm/dispatch.h | 1 + vm/layouts.h | 2 +- vm/master.h | 1 + vm/primitives.c | 3 +- 11 files changed, 296 insertions(+), 4 deletions(-) create mode 100644 core/generic/standard/compiler/authors.txt create mode 100644 core/generic/standard/compiler/compiler.factor create mode 100644 vm/dispatch.c create mode 100644 vm/dispatch.h diff --git a/Makefile b/Makefile index 35a5ba58bf..511c191711 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ + vm/dispatch.o \ vm/errors.o \ vm/factor.o \ vm/image.o \ @@ -182,5 +183,5 @@ vm/ffi_test.o: vm/ffi_test.c .m.o: $(CC) -c $(CFLAGS) -o $@ $< - + .PHONY: factor diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..ab205b4a16 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,6 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values +generic.standard.private alien.libraries stack-checker.alien stack-checker.state @@ -676,3 +677,5 @@ M: object infer-call* \ gc-stats { } { array } define-primitive \ jit-compile { quotation } { } define-primitive + +\ lookup-method { object array } { word } define-primitive \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..a8e23cd336 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,6 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.standard.private" "growable" "hashtables" "hashtables.private" @@ -532,6 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } + { "lookup-method" "generic.standard.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/standard/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/standard/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/standard/compiler/compiler.factor new file mode 100644 index 0000000000..0456918b49 --- /dev/null +++ b/core/generic/standard/compiler/compiler.factor @@ -0,0 +1,174 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.algebra math combinators +generic.standard.engines hashtables kernel kernel.private layouts +namespaces sequences words sorting quotations effects +generic.standard.private words.private ; +IN: generic.standard.compiler + +! ! ! Build an engine ! ! ! + +! 1. Flatten methods +TUPLE: predicate-engine methods ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + [ [ flatten-class keys ] keep ] 2dip [ + [ spin ] dip push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + +! 2. Convert methods +: convert-methods ( assoc class word -- assoc' ) + over [ split-methods ] 2dip pick assoc-empty? + [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline + +! 2.1 Convert tuple methods +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + [ swap dup "layout" word-prop third ] dip + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + H{ } clone [ [ push-echelon ] curry assoc-each ] keep ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! Compile engine ! ! ! +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word + +GENERIC: compile-engine ( engine -- obj ) + +: compile-engines ( assoc -- assoc' ) + [ compile-engine ] assoc-map ; + +: compile-engines* ( assoc -- assoc' ) + [ over assumed [ compile-engine ] with-variable ] assoc-map ; + +: direct-dispatch-table ( assoc n -- table ) + default get [ swap update ] keep ; + +M: tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ tag-number ] dip ] assoc-map + num-tags get direct-dispatch-table ; + +: hi-tag-number ( class -- n ) "type" word-prop ; + +: num-hi-tags ( -- n ) + num-types get num-tags get - ; + +M: hi-tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ hi-tag-number num-tags get - ] dip ] assoc-map + num-hi-tags direct-dispatch-table ; + +: build-fast-hash ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ compile-engines* >alist >array ] map ; + +M: echelon-dispatch-engine compile-engine + methods>> compile-engines* build-fast-hash ; + +M: tuple-dispatch-engine compile-engine + tuple assumed [ + echelons>> compile-engines + dup keys supremum f default get prefix + [ swap update ] keep + ] with-variable ; + +: sort-methods ( assoc -- assoc' ) + >alist [ keys sort-classes ] keep extract-keys ; + +: literalize-methods ( assoc -- assoc' ) + [ [ ] curry \ drop prefix ] assoc-map ; + +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class<= ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } + [ [ first second ] [ rest-slice ] bi ] + } cond ; + +: class-predicates ( assoc -- assoc ) + [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + +: predicate-engine-effect ( -- effect ) + (dispatch#) get 1+ dup 1+ ; + +: define-predicate-engine ( alist -- word ) + [ generic-word get name>> "/predicate-engine" append f dup ] dip + predicate-engine-effect define-declared ; + +M: predicate-engine compile-engine + methods-with-default + sort-methods + literalize-methods + prune-redundant-predicates + class-predicates + [ peek wrapped>> ] + [ alist>quot picker prepend define-predicate-engine ] if-empty ; + +M: word compile-engine ; + +M: f compile-engine ; + +: build-engine ( generic combination -- engine ) + [ + #>> (dispatch#) set + [ generic-word set ] + [ "default-method" word-prop default set ] + [ "methods" word-prop ] tri + compile-engine 1quotation + picker [ lookup-method ] surround + ] with-scope ; \ No newline at end of file diff --git a/vm/data_heap.c b/vm/data_heap.c index c5aa42aebe..eb8add544e 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -334,7 +334,7 @@ CELL next_object(void) type = untag_header(value); heap_scan_ptr += untagged_object_size(heap_scan_ptr); - return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE); + return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); } /* Push object at heap scan cursor and advance; pushes f when done */ diff --git a/vm/dispatch.c b/vm/dispatch.c new file mode 100644 index 0000000000..e231d6f431 --- /dev/null +++ b/vm/dispatch.c @@ -0,0 +1,108 @@ +#include "master.h" + +static CELL search_lookup_alist(CELL table, CELL class) +{ + F_ARRAY *pairs = untag_object(table); + F_FIXNUM index = array_capacity(pairs) - 1; + while(index >= 0) + { + F_ARRAY *pair = untag_object(array_nth(pairs,index)); + if(array_nth(pair,0) == class) + return array_nth(pair,1); + else + index--; + } + + return F; +} + +static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode) +{ + F_ARRAY *buckets = untag_object(table); + CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(type_of(bucket) == WORD_TYPE || bucket == F) + return bucket; + else + return search_lookup_alist(bucket,class); +} + +static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2]; +} + +static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2 + 1]; +} + +static CELL lookup_tuple_method(CELL object, CELL methods) +{ + F_ARRAY *echelons = untag_object(methods); + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + + F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM max_echelon = array_capacity(echelons) - 1; + if(echelon > max_echelon) echelon = max_echelon; + + while(echelon >= 0) + { + CELL echelon_methods = array_nth(echelons,echelon); + + if(type_of(echelon_methods) == WORD_TYPE) + return echelon_methods; + else if(echelon_methods != F) + { + CELL class = nth_superclass(layout,echelon); + CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL result = search_lookup_hash(echelon_methods,class,hashcode); + if(result != F) + return result; + } + + echelon--; + } + + critical_error("Cannot find tuple method",object); + return F; +} + +static CELL lookup_hi_tag_method(CELL object, CELL methods) +{ + F_ARRAY *hi_tag_methods = untag_object(methods); + CELL hi_tag = object_type(object); + return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); +} + +static CELL lookup_method(CELL object, CELL methods) +{ + F_ARRAY *tag_methods = untag_object(methods); + CELL tag = TAG(object); + CELL element = array_nth(tag_methods,tag); + + if(type_of(element) == WORD_TYPE) + return element; + else + { + switch(tag) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,element); + case OBJECT_TYPE: + return lookup_hi_tag_method(object,element); + default: + critical_error("Bad methods array",methods); + return F; + } + } +} + +void primitive_lookup_method(void) +{ + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); +} diff --git a/vm/dispatch.h b/vm/dispatch.h new file mode 100644 index 0000000000..6541c8fef1 --- /dev/null +++ b/vm/dispatch.h @@ -0,0 +1 @@ +void primitive_lookup_method(void); diff --git a/vm/layouts.h b/vm/layouts.h index e9cdef6272..9d92d2c386 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -42,7 +42,7 @@ typedef signed long long s64; #define F_TYPE 7 #define F F_TYPE -#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */ +#define HEADER_TYPE 8 /* anything less than this is a tag */ #define GC_COLLECTED 5 /* See gc.c */ diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..e2cafd9a87 100644 --- a/vm/master.h +++ b/vm/master.h @@ -41,6 +41,7 @@ #include "callstack.h" #include "alien.h" #include "quotations.h" +#include "dispatch.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 80b672d9d2..4281e88fc3 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,5 +144,6 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, - primitive_check_datastack + primitive_check_datastack, + primitive_lookup_method }; From c877146531484ef34c93113649e4e26a24687d23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 16:53:30 -0500 Subject: [PATCH 08/83] Move method-declaration to hints --- basis/hints/hints.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d445bf72ad..e2506dbe0a 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,13 +42,13 @@ SYMBOL: specialize-method? t specialize-method? set-global +: method-declaration ( method -- quot ) + [ "method-generic" word-prop dispatch# object ] + [ "method-class" word-prop ] + bi prefix [ declare ] curry [ ] like ; + : specialize-method ( quot method -- quot' ) - [ - specialize-method? get [ - [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - method-declaration prepend - ] [ drop ] if - ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 3dc9fdf9db8113cd6c8276ba0257645c5caab076 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:43:01 -0500 Subject: [PATCH 09/83] Fleshed out new dispatch code --- basis/compiler/compiler.factor | 16 +- .../tree/propagation/inlining/inlining.factor | 2 +- basis/debugger/debugger.factor | 2 +- basis/hints/hints.factor | 4 +- basis/see/see.factor | 10 +- basis/stack-checker/backend/backend.factor | 9 +- .../known-words/known-words.factor | 4 +- basis/tools/crossref/crossref.factor | 5 +- .../listener/completion/completion.factor | 12 +- core/bootstrap/primitives.factor | 4 +- .../{standard/compiler => hook}/authors.txt | 0 core/generic/hook/hook-docs.factor | 10 + core/generic/hook/hook.factor | 19 ++ core/generic/single/authors.txt | 1 + core/generic/single/single-docs.factor | 27 +++ .../compiler.factor => single/single.factor} | 125 ++++++++++--- core/generic/standard/authors.txt | 2 +- core/generic/standard/engines/engines.factor | 53 ------ .../engines/predicate/predicate.factor | 38 ---- .../standard/engines/predicate/summary.txt | 1 - core/generic/standard/engines/summary.txt | 1 - core/generic/standard/engines/tag/summary.txt | 1 - core/generic/standard/engines/tag/tag.factor | 71 ------- .../standard/engines/tuple/summary.txt | 1 - .../standard/engines/tuple/tuple.factor | 167 ----------------- core/generic/standard/standard-docs.factor | 35 +--- core/generic/standard/standard.factor | 173 ++---------------- core/generic/standard/summary.txt | 1 - core/syntax/syntax-docs.factor | 4 +- core/syntax/syntax.factor | 2 +- core/words/words.factor | 11 +- 31 files changed, 218 insertions(+), 593 deletions(-) rename core/generic/{standard/compiler => hook}/authors.txt (100%) create mode 100644 core/generic/hook/hook-docs.factor create mode 100644 core/generic/hook/hook.factor create mode 100644 core/generic/single/authors.txt create mode 100644 core/generic/single/single-docs.factor rename core/generic/{standard/compiler/compiler.factor => single/single.factor} (57%) delete mode 100644 core/generic/standard/engines/engines.factor delete mode 100644 core/generic/standard/engines/predicate/predicate.factor delete mode 100644 core/generic/standard/engines/predicate/summary.txt delete mode 100644 core/generic/standard/engines/summary.txt delete mode 100644 core/generic/standard/engines/tag/summary.txt delete mode 100644 core/generic/standard/engines/tag/tag.factor delete mode 100644 core/generic/standard/engines/tuple/summary.txt delete mode 100644 core/generic/standard/engines/tuple/tuple.factor delete mode 100644 core/generic/standard/summary.txt diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ee91d04b3d..26f9dc47c9 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors -stack-checker stack-checker.state stack-checker.inlining -stack-checker.errors combinators.short-circuit compiler.errors -compiler.units compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +generic.single combinators deques search-deques macros io +source-files.errors stack-checker stack-checker.state +stack-checker.inlining stack-checker.errors combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -19,6 +20,7 @@ SYMBOL: compiled { [ "forgotten" word-prop ] [ compiled get key? ] + [ single-generic? ] [ inlined-block? ] [ primitive? ] } 1|| not ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index aa66b2f6d7..42c47377e0 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard generic.math +math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints locals diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d8ebd5bbf9..2091a26133 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles io.pathnames vectors words system splitting math.parser classes.mixin classes.tuple continuations continuations.private combinators generic.math classes.builtin classes compiler.units -generic.standard vocabs init kernel.private io.encodings +generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index e2506dbe0a..d83275c750 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.standard generic.standard.engines classes +math.parser generic generic.single generic.standard classes hashtables namespaces ; IN: hints diff --git a/basis/see/see.factor b/basis/see/see.factor index 2494c72fa4..37153b5229 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple classes.union combinators -definitions effects generic generic.standard io io.pathnames +classes.intersection classes.mixin classes.predicate classes.singleton +classes.tuple classes.union combinators definitions effects generic +generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections sequences sets sorting strings summary -words words.symbol words.constant words.alias ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4fb5bab96f..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic io io.streams.string kernel math -namespaces parser sequences strings vectors words quotations -effects classes continuations assocs combinators -compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints macros stack-checker.state +USING: fry arrays generic io io.streams.string kernel math namespaces +parser sequences strings vectors words quotations effects classes +continuations assocs combinators compiler.errors accessors math.order +definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ab205b4a16..a3b0c8d704 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,7 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values -generic.standard.private +generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -236,6 +236,8 @@ M: object infer-call* \ effective-method t "no-compile" set-word-prop \ effective-method subwords [ t "no-compile" set-word-prop ] each +\ execute-unsafe t "no-compile" set-word-prop + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index c5cd246f2e..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -3,8 +3,7 @@ USING: words assocs definitions io io.pathnames io.styles kernel prettyprint sorting see sets sequences arrays hashtables help.crossref help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.standard.engines.tuple threads -compiler.units init ; +graphs vocabs generic generic.single threads compiler.units init ; IN: tools.crossref SYMBOL: crossref @@ -82,7 +81,7 @@ M: object irrelevant? drop f ; M: default-method irrelevant? drop t ; -M: engine-word irrelevant? drop t ; +M: predicate-engine irrelevant? drop t ; PRIVATE> diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index ba66121bc2..70131f3212 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -3,13 +3,13 @@ USING: accessors arrays assocs calendar colors colors.constants documents documents.elements fry kernel words sets splitting math math.vectors models.delay models.arrow combinators.short-circuit -parser present sequences tools.completion help.vocabs generic -generic.standard.engines.tuple fonts definitions.icons ui.images -ui.commands ui.operations ui.gadgets ui.gadgets.editors -ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.labeled +parser present sequences tools.completion help.vocabs generic fonts +definitions.icons ui.images ui.commands ui.operations ui.gadgets +ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid -ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; +ui.tools.listener.history combinators vocabs ui.tools.listener.popups + ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a8e23cd336..42627531aa 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,7 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" - "generic.standard.private" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -533,7 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.standard.private" (( object methods -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/hook/authors.txt similarity index 100% rename from core/generic/standard/compiler/authors.txt rename to core/generic/hook/authors.txt diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor new file mode 100644 index 0000000000..9b57d941c0 --- /dev/null +++ b/core/generic/hook/hook-docs.factor @@ -0,0 +1,10 @@ +USING: generic generic.single generic.standard help.markup help.syntax sequences math +math.parser effects ; +IN: generic.hook + +HELP: hook-combination +{ $class-description + "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." +} ; + +{ standard-combination hook-combination } related-words \ No newline at end of file diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor new file mode 100644 index 0000000000..0574833fab --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions generic generic.single kernel +namespaces words ; +IN: generic.hook + +TUPLE: hook-combination < single-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +M: hook-combination picker + combination get var>> [ get ] curry ; + +M: hook-combination dispatch# drop 0 ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/single/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor new file mode 100644 index 0000000000..8f81be762c --- /dev/null +++ b/core/generic/single/single-docs.factor @@ -0,0 +1,27 @@ +USING: generic help.markup help.syntax sequences math +math.parser effects ; +IN: generic.single + +HELP: no-method +{ $values { "object" "an object" } { "generic" "a generic word" } } +{ $description "Throws a " { $link no-method } " error." } +{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/single/single.factor similarity index 57% rename from core/generic/standard/compiler/compiler.factor rename to core/generic/single/single.factor index 0456918b49..d70a378c67 100644 --- a/core/generic/standard/compiler/compiler.factor +++ b/core/generic/single/single.factor @@ -1,13 +1,66 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.algebra math combinators -generic.standard.engines hashtables kernel kernel.private layouts -namespaces sequences words sorting quotations effects -generic.standard.private words.private ; -IN: generic.standard.compiler +USING: accessors arrays assocs classes classes.algebra +combinators definitions generic hashtables kernel +kernel.private layouts make math namespaces quotations +sequences words generic.single.private words.private +effects ; +IN: generic.single + +ERROR: no-method object generic ; + +ERROR: inconsistent-next-method class generic ; + +TUPLE: single-combination ; + +PREDICATE: single-generic < generic + "combination" word-prop single-combination? ; + +GENERIC: dispatch# ( word -- n ) + +M: generic dispatch# "combination" word-prop dispatch# ; + +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word +SYMBOL: combination + +: with-combination ( combination quot -- ) + [ combination ] dip with-variable ; inline + +HOOK: picker combination ( -- quot ) + +M: single-combination next-method-quot* + [ + 2dup next-method dup [ + [ + pick "predicate" word-prop % + 1quotation , + [ inconsistent-next-method ] 2curry , + \ if , + ] [ ] make picker prepend + ] [ 3drop f ] if + ] with-combination ; + +: single-effective-method ( obj word -- method ) + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; + +M: single-generic effective-method + [ [ picker ] with-combination call ] keep single-effective-method ; + +M: single-combination make-default-method + combination [ [ picker ] dip [ no-method ] curry append ] with-variable ; ! ! ! Build an engine ! ! ! +: find-default ( methods -- default ) + #! Side-effects methods. + [ object bootstrap-word ] dip delete-at* [ + drop generic-word get "default-method" word-prop + ] unless ; + ! 1. Flatten methods TUPLE: predicate-engine methods ; @@ -28,6 +81,10 @@ TUPLE: predicate-engine methods ; H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods +: split-methods ( assoc class -- first second ) + [ [ nip class<= not ] curry assoc-filter ] + [ [ nip class<= ] curry assoc-filter ] 2bi ; + : convert-methods ( assoc class word -- assoc' ) over [ split-methods ] 2dip pick assoc-empty? [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline @@ -76,10 +133,6 @@ C: tag-dispatch-engine ; ! ! ! Compile engine ! ! ! -SYMBOL: assumed -SYMBOL: default -SYMBOL: generic-word - GENERIC: compile-engine ( engine -- obj ) : compile-engines ( assoc -- assoc' ) @@ -98,8 +151,7 @@ M: tag-dispatch-engine compile-engine : hi-tag-number ( class -- n ) "type" word-prop ; -: num-hi-tags ( -- n ) - num-types get num-tags get - ; +: num-hi-tags ( -- n ) num-types get num-tags get - ; M: hi-tag-dispatch-engine compile-engine methods>> compile-engines* @@ -123,8 +175,8 @@ M: tuple-dispatch-engine compile-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; -: literalize-methods ( assoc -- assoc' ) - [ [ ] curry \ drop prefix ] assoc-map ; +: quote-methods ( assoc -- assoc' ) + [ 1quotation \ drop prefix ] assoc-map ; : methods-with-default ( engine -- assoc ) methods>> clone default get object bootstrap-word pick set-at ; @@ -141,34 +193,49 @@ M: tuple-dispatch-engine compile-engine } cond ; : class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; -: predicate-engine-effect ( -- effect ) - (dispatch#) get 1+ dup 1+ ; +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +: ( -- word ) + generic-word get name>> "/predicate-engine" append f + dup generic-word get "owner-generic" set-word-prop ; + +M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; : define-predicate-engine ( alist -- word ) - [ generic-word get name>> "/predicate-engine" append f dup ] dip - predicate-engine-effect define-declared ; + [ ] dip + [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; M: predicate-engine compile-engine methods-with-default sort-methods - literalize-methods + quote-methods prune-redundant-predicates class-predicates - [ peek wrapped>> ] - [ alist>quot picker prepend define-predicate-engine ] if-empty ; + [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: word compile-engine ; M: f compile-engine ; -: build-engine ( generic combination -- engine ) - [ - #>> (dispatch#) set +: build-decision-tree ( generic -- methods ) + { [ generic-word set ] - [ "default-method" word-prop default set ] - [ "methods" word-prop ] tri - compile-engine 1quotation - picker [ lookup-method ] surround - ] with-scope ; \ No newline at end of file + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] + } cleave ; + +: execute-unsafe ( word -- ) (execute) ; + +M: single-combination perform-combination + [ + dup build-decision-tree + [ "decision-tree" set-word-prop ] + [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi + ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt index 1901f27a24..d4f5d6b3ae 100644 --- a/core/generic/standard/authors.txt +++ b/core/generic/standard/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor deleted file mode 100644 index b6cb9fc9f7..0000000000 --- a/core/generic/standard/engines/engines.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel kernel.private namespaces quotations -generic math sequences combinators words classes.algebra arrays -; -IN: generic.standard.engines - -SYMBOL: default -SYMBOL: assumed -SYMBOL: (dispatch#) - -GENERIC: engine>quot ( engine -- quot ) - -: engines>quots ( assoc -- assoc' ) - [ engine>quot ] assoc-map ; - -: engines>quots* ( assoc -- assoc' ) - [ over assumed [ engine>quot ] with-variable ] assoc-map ; - -: if-small? ( assoc true false -- ) - [ dup assoc-size 4 <= ] 2dip if ; inline - -: linear-dispatch-quot ( alist -- quot ) - default get [ drop ] prepend swap - [ - [ [ dup ] swap [ eq? ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: split-methods ( assoc class -- first second ) - [ [ nip class<= not ] curry assoc-filter ] - [ [ nip class<= ] curry assoc-filter ] 2bi ; - -: convert-methods ( assoc class word -- assoc' ) - over [ split-methods ] 2dip pick assoc-empty? [ - 3drop - ] [ - [ execute ] dip pick set-at - ] if ; inline - -: (picker) ( n -- quot ) - { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -GENERIC: extra-values ( generic -- n ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor deleted file mode 100644 index 152b112c2a..0000000000 --- a/core/generic/standard/engines/predicate/predicate.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic.standard.engines generic namespaces kernel -kernel.private sequences classes.algebra accessors words -combinators assocs arrays ; -IN: generic.standard.engines.predicate - -TUPLE: predicate-dispatch-engine methods ; - -C: predicate-dispatch-engine - -: class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; - -: keep-going? ( assoc -- ? ) - assumed get swap second first class<= ; - -: prune-redundant-predicates ( assoc -- default assoc' ) - { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ first second { } ] } - { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } - [ [ first second ] [ rest-slice ] bi ] - } cond ; - -: sort-methods ( assoc -- assoc' ) - >alist [ keys sort-classes ] keep extract-keys ; - -: methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; - -M: predicate-dispatch-engine engine>quot - methods-with-default - engines>quots - sort-methods - prune-redundant-predicates - class-predicates - alist>quot ; diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt deleted file mode 100644 index 47fee09ee5..0000000000 --- a/core/generic/standard/engines/predicate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Chained-conditional dispatch strategy diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt deleted file mode 100644 index 209190799b..0000000000 --- a/core/generic/standard/engines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Generic word dispatch strategy implementation diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt deleted file mode 100644 index 3eea4b11cf..0000000000 --- a/core/generic/standard/engines/tag/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Jump table keyed by pointer tag dispatch strategy diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor deleted file mode 100644 index 5ed33009c0..0000000000 --- a/core/generic/standard/engines/tag/tag.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.private generic.standard.engines namespaces make -arrays assocs sequences.private quotations kernel.private -math slots.private math.private kernel accessors words -layouts sorting sequences combinators ; -IN: generic.standard.engines.tag - -TUPLE: lo-tag-dispatch-engine methods ; - -C: lo-tag-dispatch-engine - -: direct-dispatch-quot ( alist n -- quot ) - default get - [ swap update ] keep - [ dispatch ] curry >quotation ; - -: lo-tag-number ( class -- n ) - dup \ hi-tag bootstrap-word eq? [ - drop \ hi-tag tag-number - ] [ - "type" word-prop - ] if ; - -: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; - -: tag-dispatch-test ( tag# -- quot ) - picker [ tag ] append swap [ eq? ] curry append ; - -: tag-dispatch-quot ( alist -- quot ) - [ default get ] dip - [ [ tag-dispatch-test ] dip ] assoc-map - alist>quot ; - -M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ lo-tag-number ] dip ] assoc-map - [ - [ sort-tags tag-dispatch-quot ] - [ picker % [ tag ] % num-tags get direct-dispatch-quot ] - if-small? % - ] [ ] make ; - -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) - "type" word-prop ; - -: hi-tag-quot ( -- quot ) - \ hi-tag def>> ; - -M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ hi-tag-number ] dip ] assoc-map - [ - picker % hi-tag-quot % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get , \ fixnum-fast , - [ [ num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-quot - ] if-small? % - ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt deleted file mode 100644 index cb18ac5c78..0000000000 --- a/core/generic/standard/engines/tuple/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple class dispatch strategy diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor deleted file mode 100644 index a0711af095..0000000000 --- a/core/generic/standard/engines/tuple/tuple.factor +++ /dev/null @@ -1,167 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple.private hashtables assocs sorting -accessors combinators sequences slots.private math.parser words -effects namespaces make generic generic.standard.engines -classes.algebra math math.private kernel.private -quotations arrays definitions ; -IN: generic.standard.engines.tuple - -: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline - -: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline - -: tuple-layout% ( -- ) - [ { tuple } declare 1 slot { array } declare ] % ; inline - -: tuple-layout-echelon% ( -- ) - [ 4 slot ] % ; inline - -TUPLE: echelon-dispatch-engine n methods ; - -C: echelon-dispatch-engine - -TUPLE: trivial-tuple-dispatch-engine n methods ; - -C: trivial-tuple-dispatch-engine - -TUPLE: tuple-dispatch-engine echelons ; - -: push-echelon ( class method assoc -- ) - [ swap dup "layout" word-prop third ] dip - [ ?set-at ] change-at ; - -: echelon-sort ( assoc -- assoc' ) - V{ } clone [ - [ - push-echelon - ] curry assoc-each - ] keep sort-keys ; - -: ( methods -- engine ) - echelon-sort - [ dupd ] assoc-map - \ tuple-dispatch-engine boa ; - -: convert-tuple-methods ( assoc -- assoc' ) - tuple bootstrap-word - \ convert-methods ; - -M: trivial-tuple-dispatch-engine engine>quot - [ n>> ] [ methods>> ] bi dup assoc-empty? [ - 2drop default get [ drop ] prepend - ] [ - [ - [ nth-superclass% ] - [ engines>quots* linear-dispatch-quot % ] bi* - ] [ ] make - ] if ; - -: hash-methods ( n methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] with map ; - -: class-hash-dispatch-quot ( n methods -- quot ) - [ - \ dup , - [ drop nth-hashcode% ] - [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi - ] [ ] make ; - -: engine-word-name ( -- string ) - generic get name>> "/tuple-dispatch-engine" append ; - -PREDICATE: engine-word < word - "tuple-dispatch-generic" word-prop generic? ; - -M: engine-word stack-effect - "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect ] bi - dup [ - [ in>> length + ] [ out>> ] [ terminated?>> ] tri - effect boa - ] [ 2drop f ] if ; - -M: engine-word where "tuple-dispatch-generic" word-prop where ; - -M: engine-word crossref? "forgotten" word-prop not ; - -: remember-engine ( word -- ) - generic get "engines" word-prop push ; - -: ( -- word ) - engine-word-name f - dup generic get "tuple-dispatch-generic" set-word-prop ; - -: define-engine-word ( quot -- word ) - [ dup ] dip define ; - -: tuple-dispatch-engine-body ( engine -- quot ) - [ - picker % - tuple-layout% - [ n>> ] [ methods>> ] bi - [ engine>quot ] - [ class-hash-dispatch-quot ] - if-small? % - ] [ ] make ; - -M: echelon-dispatch-engine engine>quot - dup n>> zero? [ - methods>> dup assoc-empty? - [ drop default get ] [ values first engine>quot ] if - ] [ - tuple-dispatch-engine-body - ] if ; - -: >=-case-quot ( default alist -- quot ) - [ [ drop ] prepend ] dip - [ - [ [ dup ] swap [ fixnum>= ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: simplify-echelon-alist ( default alist -- default' alist' ) - dup empty? [ - dup first first 1 <= [ - nip unclip second swap - simplify-echelon-alist - ] when - ] unless ; - -: echelon-case-quot ( alist -- quot ) - #! We don't have to test for echelon 1 since all tuple - #! classes are at least at depth 1 in the inheritance - #! hierarchy. - default get swap simplify-echelon-alist - [ - [ - picker % - tuple-layout% - tuple-layout-echelon% - >=-case-quot % - ] [ ] make - ] unless-empty ; - -M: tuple-dispatch-engine engine>quot - [ - [ - tuple assumed set - echelons>> unclip-last - [ - [ - engine>quot - over 0 = [ - define-engine-word - [ remember-engine ] [ 1quotation ] bi - ] unless - dup default set - ] assoc-map - ] - [ first2 engine>quot 2array ] bi* - suffix - ] with-scope - echelon-case-quot % - ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 6e788eb947..33da0037b3 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,12 +1,7 @@ -USING: generic help.markup help.syntax sequences math +USING: generic generic.single help.markup help.syntax sequences math math.parser effects ; IN: generic.standard -HELP: no-method -{ $values { "object" "an object" } { "generic" "a generic word" } } -{ $description "Throws a " { $link no-method } " error." } -{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; - HELP: standard-combination { $class-description "Performs standard method combination." @@ -22,32 +17,6 @@ HELP: standard-combination } } ; -HELP: hook-combination -{ $class-description - "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." -} ; - HELP: define-simple-generic { $values { "word" "a word" } { "effect" effect } } -{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; - -{ standard-combination hook-combination } related-words - -HELP: inconsistent-next-method -{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } -{ $examples - "The following code throws this error:" - { $code - "GENERIC: error-test ( object -- )" - "" - "M: string error-test print ;" - "" - "M: integer error-test number>string call-next-method ;" - "" - "123 error-test" - } - "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." - $nl - "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" - { $code "M: integer error-test number>string error-test ;" } -} ; +{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..bbf458ef1d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,100 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces make sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; +USING: accessors definitions generic generic.single kernel +namespaces words math combinators ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) - -M: generic dispatch# - "combination" word-prop dispatch# ; - -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - [ picker ] dip [ no-method ] curry append ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* - [ methods>> set-at ] keep - ] change-at ; - -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; - -: flatten-methods ( assoc -- assoc' ) - H{ } clone [ - [ - flatten-method - ] curry assoc-each - ] keep ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: mangle-method ( method -- quot ) - 1quotation generic get extra-values \ drop - prepend [ ] like ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - [ object bootstrap-word ] dip delete-at* [ - drop generic get "default-method" word-prop mangle-method - ] unless ; - -: ( word -- engine ) - object bootstrap-word assumed set { - [ generic set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop - [ mangle-method ] assoc-map - [ find-default default set ] - [ ] - bi - ] - } cleave ; - -: single-combination ( word -- quot ) - [ engine>quot ] with-scope ; - -ERROR: inconsistent-next-method class generic ; - -: single-next-method-quot ( class generic -- quot/f ) - 2dup next-method dup [ - [ - pick "predicate" word-prop % - 1quotation , - [ inconsistent-next-method ] 2curry , - \ if , - ] [ ] make - ] [ 3drop f ] if ; - -: single-effective-method ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] - [ "default-method" word-prop ] - bi or ; - -TUPLE: standard-combination # ; +TUPLE: standard-combination < single-combination # ; C: standard-combination @@ -102,79 +12,26 @@ PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; + "combination" word-prop #>> 0 = ; CONSTANT: simple-combination T{ standard-combination f 0 } : define-simple-generic ( word effect -- ) [ simple-combination ] dip define-generic ; -: with-standard ( combination quot -- quot' ) - [ #>> (dispatch#) ] dip with-variable ; inline +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- (picker) [ dip swap ] curry ] + } case ; -M: standard-generic extra-values drop 0 ; - -M: standard-combination make-default-method - [ error-method ] with-standard ; - -M: standard-combination perform-combination - [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination picker + combination get #>> (picker) ; M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - -M: standard-combination next-method-quot* - [ - single-next-method-quot - dup [ picker prepend ] when - ] with-standard ; - -M: standard-generic effective-method - [ dispatch# (picker) call ] keep single-effective-method ; - -TUPLE: hook-combination var ; - -C: hook-combination - -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - [ hook-combination ] dip with-variable - ] with-variable ; inline - -: prepend-hook-var ( quot -- quot' ) - hook-combination get var>> [ get ] curry prepend ; - -M: hook-combination dispatch# drop 0 ; - -M: hook-combination method-declaration 2drop [ ] ; - -M: hook-generic extra-values drop 1 ; - -M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep - single-effective-method ; - -M: hook-combination make-default-method - [ error-method prepend-hook-var ] with-hook ; - -M: hook-combination perform-combination - [ drop ] [ - [ single-combination prepend-hook-var ] with-hook - ] 2bi define ; - -M: hook-combination next-method-quot* - [ - single-next-method-quot - dup [ prepend-hook-var ] when - ] with-hook ; - M: simple-generic definer drop \ GENERIC: f ; -M: standard-generic definer drop \ GENERIC# f ; - -M: hook-generic definer drop \ HOOK: f ; +M: standard-generic definer drop \ GENERIC# f ; \ No newline at end of file diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt deleted file mode 100644 index 5e731c6f15..0000000000 --- a/core/generic/standard/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Standard method combination used for most generic words diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 7ab287fd20..e8f86faa9d 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant combinators ; +generic.standard generic.single arrays io.pathnames vocabs.loader io +sequences assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2e072f72d8..3512b92e4c 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes +generic.standard generic.hook generic.math generic.parser classes io.pathnames vocabs vocabs.parser classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units diff --git a/core/words/words.factor b/core/words/words.factor index eb0599db78..894b671494 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,8 +154,15 @@ M: word reset-word : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; From d03b1eef01778242512c6fb0a7fd542fb7ab78e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:54:30 -0500 Subject: [PATCH 10/83] Compile methods of generic words since the generic word itself doesn't get compiled --- basis/compiler/compiler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 26f9dc47c9..efa6294c98 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -163,7 +163,10 @@ M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set H{ } clone compiled set - [ queue-compile ] each + [ + [ queue-compile ] + [ subwords [ compile-dependency ] each ] bi + ] each compile-queue get compile-loop compiled get >alist ] with-scope ; From 7aa65b5b5fd1446ea42d09e157b850fdb8cf0487 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 19:41:27 -0500 Subject: [PATCH 11/83] Fixing new method dispatch implementation --- basis/compiler/compiler.factor | 25 ++++++++++---- basis/debugger/debugger-docs.factor | 2 +- basis/listener/listener.factor | 2 ++ .../known-words/known-words.factor | 8 ----- .../transforms/transforms.factor | 1 - .../tools/continuations/continuations.factor | 5 ++- basis/ui/tools/error-list/error-list.factor | 2 +- .../listener/completion/completion.factor | 5 +-- core/classes/tuple/tuple-tests.factor | 16 ++++----- core/generic/generic-docs.factor | 3 +- core/generic/hook/hook.factor | 3 ++ .../single-tests.factor} | 34 +++++-------------- core/generic/single/single.factor | 31 +++++++++++------ core/generic/standard/standard.factor | 10 ++++-- core/layouts/layouts.factor | 8 ++--- core/sequences/sequences-docs.factor | 4 +-- 16 files changed, 80 insertions(+), 79 deletions(-) rename core/generic/{standard/standard-tests.factor => single/single-tests.factor} (88%) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index efa6294c98..d86c9234d1 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -15,18 +15,17 @@ IN: compiler SYMBOL: compile-queue SYMBOL: compiled -: queue-compile? ( word -- ? ) +: compile? ( word -- ? ) #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] [ compiled get key? ] - [ single-generic? ] [ inlined-block? ] [ primitive? ] } 1|| not ; : queue-compile ( word -- ) - dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; + dup compile? [ compile-queue get push-front ] [ drop ] if ; : recompile-callers? ( word -- ? ) changed-effects get key? ; @@ -43,6 +42,14 @@ SYMBOL: compiled H{ } clone generic-dependencies set clear-compiler-error ; +GENERIC: no-compile? ( word -- ? ) + +M: word no-compile? "no-compile" word-prop ; + +M: method-body no-compile? "method-generic" word-prop no-compile? ; + +M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; + : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. @@ -50,8 +57,8 @@ SYMBOL: compiled { [ macro? ] [ inline? ] + [ no-compile? ] [ "special" word-prop ] - [ "no-compile" word-prop ] } 1|| ] [ { @@ -98,12 +105,16 @@ SYMBOL: compiled 2bi ] if ; +: optimize? ( word -- ? ) + { [ contains-breakpoints? ] [ single-generic? ] } 1|| not ; + : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since #! the walker does not support this. - dup contains-breakpoints? [ dup def>> deoptimize-with ] [ - [ build-tree ] [ deoptimize ] recover optimize-tree - ] if ; + dup optimize? + [ [ build-tree ] [ deoptimize ] recover optimize-tree ] + [ dup def>> deoptimize-with ] + if ; : compile-dependency ( word -- ) #! If a word calls an unoptimized word, try to compile the callee. diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index ff5869efab..ff9986432c 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/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 io.files.private listener +help generic.single continuations io.files.private listener alien.libraries ; IN: debugger diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index d96e0df6c1..68777f2f73 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -62,6 +62,8 @@ SYMBOL: max-stack-items SYMBOL: error-summary? +t error-summary? set-global + > (step-into-quot) ] diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index aa23a8ebe1..704ae112e5 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -10,7 +10,7 @@ ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +ui.gadgets.labels ui.baseline-alignment ui.images compiler.errors tools.errors tools.errors.model ; IN: ui.tools.error-list diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 70131f3212..17216bd656 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -8,8 +8,7 @@ definitions.icons ui.images ui.commands ui.operations ui.gadgets ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid -ui.tools.listener.history combinators vocabs ui.tools.listener.popups - ; +ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots @@ -120,8 +119,6 @@ M: object completion-string present ; M: method-body completion-string method-completion-string ; -M: engine-word completion-string method-completion-string ; - GENERIC# accept-completion-hook 1 ( item popup -- ) : insert-completion ( item popup -- ) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index c180807b0c..466b221877 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -1,11 +1,11 @@ -USING: definitions generic kernel kernel.private math -math.constants parser sequences tools.test words assocs -namespaces quotations sequences.private classes continuations -generic.standard effects classes.tuple classes.tuple.private -arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting summary -columns math.order classes.private slots slots.private eval see -words.symbol compiler.errors ; +USING: definitions generic kernel kernel.private math math.constants +parser sequences tools.test words assocs namespaces quotations +sequences.private classes continuations generic.single +generic.standard effects classes.tuple classes.tuple.private arrays +vectors strings compiler.units accessors classes.algebra calendar +prettyprint io.streams.string splitting summary columns math.order +classes.private slots slots.private eval see words.symbol +compiler.errors ; IN: classes.tuple.tests TUPLE: rect x y w h ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index e8b5e6d69c..73002a5d89 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,7 @@ USING: help.markup help.syntax words classes classes.algebra definitions kernel alien sequences math quotations -generic.standard generic.math combinators prettyprint effects ; +generic.single generic.standard generic.hook generic.math +combinators prettyprint effects ; IN: generic ARTICLE: "method-order" "Method precedence" diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index 0574833fab..a44d071e4d 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -17,3 +17,6 @@ M: hook-combination picker M: hook-combination dispatch# drop 0 ; M: hook-generic definer drop \ HOOK: f ; + +M: hook-generic effective-method + [ "combination" word-prop var>> get ] keep (effective-method) ; \ No newline at end of file diff --git a/core/generic/standard/standard-tests.factor b/core/generic/single/single-tests.factor similarity index 88% rename from core/generic/standard/standard-tests.factor rename to core/generic/single/single-tests.factor index 58007f795f..8245cbe22f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/single/single-tests.factor @@ -1,11 +1,10 @@ -IN: generic.standard.tests -USING: tools.test math math.functions math.constants -generic.standard strings sequences arrays kernel accessors words -specialized-arrays.double byte-arrays bit-arrays parser -namespaces make quotations stack-checker vectors growable -hashtables sbufs prettyprint byte-vectors bit-vectors -specialized-vectors.double definitions generic sets graphs assocs -grouping see ; +IN: generic.single.tests +USING: tools.test math math.functions math.constants generic.standard +generic.single strings sequences arrays kernel accessors words +specialized-arrays.double byte-arrays bit-arrays parser namespaces +make quotations stack-checker vectors growable hashtables sbufs +prettyprint byte-vectors bit-vectors specialized-vectors.double +definitions generic sets graphs assocs grouping see ; GENERIC: lo-tag-test ( obj -- obj' ) @@ -249,23 +248,6 @@ M: string my-hook "a string" ; [ "a string" ] [ my-hook my-var set my-hook ] unit-test [ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with -HOOK: my-tuple-hook my-var ( -- x ) - -M: sequence my-tuple-hook my-hook ; - -TUPLE: m-t-h-a ; - -M: m-t-h-a my-tuple-hook "foo" ; - -TUPLE: m-t-h-b < m-t-h-a ; - -M: m-t-h-b my-tuple-hook "bar" ; - -[ f ] [ - \ my-tuple-hook [ "engines" word-prop ] keep prefix - [ 1quotation infer ] map all-equal? -] unit-test - HOOK: call-next-hooker my-var ( -- x ) M: sequence call-next-hooker "sequence" ; @@ -281,7 +263,7 @@ M: growable call-next-hooker call-next-method "growable " prepend ; ] unit-test [ t ] [ - { } \ nth effective-method nip \ sequence \ nth method eq? + { } \ nth effective-method nip M\ sequence nth eq? ] unit-test [ t ] [ diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index d70a378c67..7624fbfb7d 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -42,16 +42,13 @@ M: single-combination next-method-quot* ] [ 3drop f ] if ] with-combination ; -: single-effective-method ( obj word -- method ) +: (effective-method) ( obj word -- method ) [ [ order [ instance? ] with find-last nip ] keep method ] [ "default-method" word-prop ] bi or ; -M: single-generic effective-method - [ [ picker ] with-combination call ] keep single-effective-method ; - M: single-combination make-default-method - combination [ [ picker ] dip [ no-method ] curry append ] with-variable ; + [ [ picker ] dip [ no-method ] curry append ] with-combination ; ! ! ! Build an engine ! ! ! @@ -101,7 +98,10 @@ TUPLE: tuple-dispatch-engine echelons ; [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) - H{ } clone [ [ push-echelon ] curry assoc-each ] keep ; + #! Convert an assoc mapping classes to methods into an + #! assoc mapping echelons to assocs. The first echelon + #! is always there + H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ; : ( methods -- engine ) echelon-sort @@ -127,9 +127,13 @@ TUPLE: tag-dispatch-engine methods ; C: tag-dispatch-engine : ( assoc -- engine ) + dup keys [ not ] filter [ "FOO" throw ] unless-empty flatten-methods + dup keys [ not ] filter [ "FOO1" throw ] unless-empty convert-tuple-methods + dup keys [ not ] filter [ "FOO2" throw ] unless-empty convert-hi-tag-methods + dup keys [ not ] filter [ "FOO3" throw ] unless-empty ; ! ! ! Compile engine ! ! ! @@ -146,7 +150,7 @@ GENERIC: compile-engine ( engine -- obj ) M: tag-dispatch-engine compile-engine methods>> compile-engines* - [ [ tag-number ] dip ] assoc-map + [ [ global [ target-word ] bind tag-number ] dip ] assoc-map num-tags get direct-dispatch-table ; : hi-tag-number ( class -- n ) "type" word-prop ; @@ -159,16 +163,23 @@ M: hi-tag-dispatch-engine compile-engine num-hi-tags direct-dispatch-table ; : build-fast-hash ( methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets + V{ } clone [ hashcode 1array ] distribute-buckets [ compile-engines* >alist >array ] map ; M: echelon-dispatch-engine compile-engine - methods>> compile-engines* build-fast-hash ; + dup n>> 0 = [ + methods>> dup assoc-size { + { 0 [ drop default get ] } + { 1 [ >alist first second compile-engine ] } + } case + ] [ + methods>> compile-engines* build-fast-hash + ] if ; M: tuple-dispatch-engine compile-engine tuple assumed [ echelons>> compile-engines - dup keys supremum f default get prefix + dup keys supremum 1+ f [ swap update ] keep ] with-variable ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index bbf458ef1d..bf8ea8da08 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions generic generic.single kernel -namespaces words math combinators ; +namespaces words math combinators sequences ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -32,6 +32,10 @@ M: standard-combination picker M: standard-combination dispatch# #>> ; -M: simple-generic definer drop \ GENERIC: f ; +M: standard-generic effective-method + [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep + (effective-method) ; -M: standard-generic definer drop \ GENERIC# f ; \ No newline at end of file +M: standard-generic definer drop \ GENERIC# f ; + +M: simple-generic definer drop \ GENERIC: f ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 5a32ca2dce..e30245abd1 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel assocs classes math.order kernel.private ; @@ -16,12 +16,12 @@ SYMBOL: tag-numbers SYMBOL: type-numbers -: tag-number ( class -- n ) - tag-numbers get at [ object tag-number ] unless* ; - : type-number ( class -- n ) type-numbers get at ; +: tag-number ( class -- n ) + type-number dup num-tags get >= [ drop object tag-number ] when ; + : tag-fixnum ( n -- tagged ) tag-bits get shift ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 556e41249e..cfd96789b4 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax math sequences.private vectors strings kernel math.order layouts -quotations generic.standard ; +quotations generic.single ; IN: sequences HELP: sequence @@ -1466,8 +1466,8 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection produce } { $subsection produce-as } "Filtering:" -{ $subsection push-if } { $subsection filter } +{ $subsection partition } "Testing if a sequence contains elements satisfying a predicate:" { $subsection any? } { $subsection all? } From 2630c4a95f7c976051bc3fa1372ea3a211d3c4fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 20:33:52 -0500 Subject: [PATCH 12/83] Add local caching --- basis/bootstrap/compiler/compiler.factor | 5 +- core/bootstrap/primitives.factor | 2 +- core/generic/single/single.factor | 17 +++++-- vm/dispatch.c | 58 ++++++++++++++++++++---- vm/dispatch.h | 2 + 5 files changed, 70 insertions(+), 14 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 89a0ed86fe..3eda3bcc37 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io -io.encodings.string libc splitting math.parser +io.encodings.string libc splitting math.parser memory compiler.units math.order compiler.tree.builder compiler.tree.optimizer compiler.cfg.optimizer ; IN: bootstrap.compiler @@ -25,6 +25,9 @@ IN: bootstrap.compiler enable-compiler +! Push all tuple layouts to tenured space to improve method caching +gc + : compile-unoptimized ( words -- ) [ optimized>> not ] filter compile ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 42627531aa..7ec1092293 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,7 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.single.private" (( object methods -- method )) } + { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 7624fbfb7d..6fd339aa21 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs classes classes.algebra combinators definitions generic hashtables kernel kernel.private layouts make math namespaces quotations sequences words generic.single.private words.private -effects ; +effects make ; IN: generic.single ERROR: no-method object generic ; @@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine num-hi-tags direct-dispatch-table ; : build-fast-hash ( methods -- buckets ) - V{ } clone [ hashcode 1array ] distribute-buckets + >alist V{ } clone [ hashcode 1array ] distribute-buckets [ compile-engines* >alist >array ] map ; M: echelon-dispatch-engine compile-engine @@ -244,9 +244,20 @@ M: f compile-engine ; : execute-unsafe ( word -- ) (execute) ; +: make-empty-cache ( -- array ) + generic-word get "methods" word-prop + assoc-size 2 * next-power-of-2 f ; + M: single-combination perform-combination [ dup build-decision-tree [ "decision-tree" set-word-prop ] - [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi + [ + [ + picker % + , + make-empty-cache , + [ lookup-method execute-unsafe ] % + ] [ ] make define + ] 2bi ] with-combination ; \ No newline at end of file diff --git a/vm/dispatch.c b/vm/dispatch.c index e231d6f431..3d6502d7b0 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -38,11 +38,25 @@ static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) return ptr[echelon * 2 + 1]; } -static CELL lookup_tuple_method(CELL object, CELL methods) +INLINE CELL method_cache_hashcode(F_TUPLE_LAYOUT *layout, F_ARRAY *array) +{ + CELL capacity = (array_capacity(array) >> 1) - 1; + return (((CELL)layout >> TAG_BITS) & capacity) << 1; +} + +INLINE CELL lookup_tuple_method_fast(F_TUPLE_LAYOUT *layout, CELL method_cache) +{ + F_ARRAY *array = untag_object(method_cache); + CELL hashcode = method_cache_hashcode(layout,array); + if(array_nth(array,hashcode) == tag_object(layout)) + return array_nth(array,hashcode + 1); + else + return F; +} + +static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods) { F_ARRAY *echelons = untag_object(methods); - F_TUPLE *tuple = untag_object(object); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); F_FIXNUM max_echelon = array_capacity(echelons) - 1; @@ -66,10 +80,34 @@ static CELL lookup_tuple_method(CELL object, CELL methods) echelon--; } - critical_error("Cannot find tuple method",object); + critical_error("Cannot find tuple method",methods); return F; } +static void update_method_cache(F_TUPLE_LAYOUT *layout, CELL method_cache, CELL method) +{ + F_ARRAY *array = untag_object(method_cache); + CELL hashcode = method_cache_hashcode(layout,array); + set_array_nth(array,hashcode,tag_object(layout)); + set_array_nth(array,hashcode + 1,method); +} + +static CELL lookup_tuple_method(CELL object, CELL methods, CELL method_cache) +{ + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + + CELL method = lookup_tuple_method_fast(layout,method_cache); + if(method == F) + { + local_cache_misses++; + method = lookup_tuple_method_slow(layout,methods); + update_method_cache(layout,method_cache,method); + } + + return method; +} + static CELL lookup_hi_tag_method(CELL object, CELL methods) { F_ARRAY *hi_tag_methods = untag_object(methods); @@ -77,7 +115,7 @@ static CELL lookup_hi_tag_method(CELL object, CELL methods) return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); } -static CELL lookup_method(CELL object, CELL methods) +static CELL lookup_method(CELL object, CELL methods, CELL method_cache) { F_ARRAY *tag_methods = untag_object(methods); CELL tag = TAG(object); @@ -90,7 +128,7 @@ static CELL lookup_method(CELL object, CELL methods) switch(tag) { case TUPLE_TYPE: - return lookup_tuple_method(object,element); + return lookup_tuple_method(object,element,method_cache); case OBJECT_TYPE: return lookup_hi_tag_method(object,element); default: @@ -102,7 +140,9 @@ static CELL lookup_method(CELL object, CELL methods) void primitive_lookup_method(void) { - CELL methods = dpop(); - CELL object = dpop(); - dpush(lookup_method(object,methods)); + CELL method_cache = get(ds); + CELL methods = get(ds - CELLS); + CELL object = get(ds - CELLS * 2); + ds -= CELLS * 2; + drepl(lookup_method(object,methods,method_cache)); } diff --git a/vm/dispatch.h b/vm/dispatch.h index 6541c8fef1..5d783f488d 100644 --- a/vm/dispatch.h +++ b/vm/dispatch.h @@ -1 +1,3 @@ +u64 local_cache_misses; + void primitive_lookup_method(void); From 27c84e89fe34ceb06bfcc6cbe0fed2d5fee8addb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 21:14:59 -0500 Subject: [PATCH 13/83] Working on faster (execute) --- basis/bootstrap/image/image.factor | 10 ++++++++++ basis/cpu/x86/bootstrap.factor | 21 ++++++++++++--------- 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 504afae018..3a0cc77f61 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -137,6 +137,9 @@ SYMBOL: jit-2dip-word SYMBOL: jit-2dip SYMBOL: jit-3dip-word SYMBOL: jit-3dip +SYMBOL: jit-execute-word +SYMBOL: jit-execute-jump +SYMBOL: jit-execute-call SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling @@ -173,6 +176,9 @@ SYMBOL: undefined-quot { jit-2dip 47 } { jit-3dip-word 48 } { jit-3dip 49 } + { jit-execute-word 50 } + { jit-execute-jump 51 } + { jit-execute-call 52 } { undefined-quot 60 } } ; inline @@ -486,6 +492,7 @@ M: quotation ' \ dip jit-dip-word set \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set + \ (execute) jit-execute-word set [ undefined ] undefined-quot set { jit-code-format @@ -506,6 +513,9 @@ M: quotation ' jit-2dip jit-3dip-word jit-3dip + jit-execute-word + jit-execute-jump + jit-execute-call jit-epilog jit-return jit-profiling diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index b63d31364b..e1cbcc5d97 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -151,6 +151,18 @@ big-endian off jit-3r> ] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define +: prepare-(execute) ( -- operand ) + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! execute word + temp0 word-xt-offset [+] ; + +[ prepare-(execute) JMP ] f f f jit-execute-jump jit-define + +[ prepare-(execute) CALL ] f f f jit-execute-call jit-define + [ ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD @@ -170,15 +182,6 @@ big-endian off arg quot-xt-offset [+] JMP ] f f f \ (call) define-sub-primitive -[ - ! load from stack - temp0 ds-reg [] MOV - ! pop stack - ds-reg bootstrap-cell SUB - ! execute word - temp0 word-xt-offset [+] JMP -] f f f \ (execute) define-sub-primitive - ! Objects [ ! load from stack From 356537593e908b67d5bb20d34b69e537fb4004bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 21:50:34 -0500 Subject: [PATCH 14/83] Get rid of execute-unsafe now that (execute) is more versatile --- .../known-words/known-words.factor | 1 - core/generic/single/single.factor | 4 +- vm/quotations.c | 66 +++++++++---------- vm/run.h | 3 + 4 files changed, 37 insertions(+), 37 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0525aa4a52..e7693b9ecd 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -229,7 +229,6 @@ M: object infer-call* ! More words not to compile \ call t "no-compile" set-word-prop \ execute t "no-compile" set-word-prop -\ execute-unsafe t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 6fd339aa21..5cb93aae08 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -242,8 +242,6 @@ M: f compile-engine ; ] } cleave ; -: execute-unsafe ( word -- ) (execute) ; - : make-empty-cache ( -- array ) generic-word get "methods" word-prop assoc-size 2 * next-power-of-2 f ; @@ -257,7 +255,7 @@ M: single-combination perform-combination picker % , make-empty-cache , - [ lookup-method execute-unsafe ] % + [ lookup-method (execute) ] % ] [ ] make define ] 2bi ] with-combination ; \ No newline at end of file diff --git a/vm/quotations.c b/vm/quotations.c index d08fecdefb..6291bd6839 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -122,6 +122,12 @@ F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p) GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \ } +#define EMIT_TAIL_CALL(name) { \ + if(stack_frame) EMIT(userenv[JIT_EPILOG]); \ + tail_call = true; \ + EMIT(name); \ + } + bool jit_stack_frame_p(F_ARRAY *array) { F_FIXNUM length = array_capacity(array); @@ -213,21 +219,21 @@ void jit_compile(CELL quot, bool relocate) EMIT(word->subprimitive); } + else if(obj == userenv[JIT_EXECUTE_WORD]) + { + if(i == length - 1) + EMIT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP]) + else + EMIT(userenv[JIT_EXECUTE_CALL]) + } else { GROWABLE_ARRAY_ADD(literals,obj); if(i == length - 1) - { - if(stack_frame) - EMIT(userenv[JIT_EPILOG]); - - EMIT(userenv[JIT_WORD_JUMP]); - - tail_call = true; - } + EMIT_TAIL_CALL(userenv[JIT_WORD_JUMP]) else - EMIT(userenv[JIT_WORD_CALL]); + EMIT(userenv[JIT_WORD_CALL]) } break; case WRAPPER_TYPE: @@ -253,6 +259,8 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(userenv[JIT_EPILOG]); + tail_call = true; + jit_compile(array_nth(untag_object(array),i),relocate); jit_compile(array_nth(untag_object(array),i + 1),relocate); @@ -263,7 +271,6 @@ void jit_compile(CELL quot, bool relocate) i += 2; - tail_call = true; break; } else if(jit_fast_dip_p(untag_object(array),i)) @@ -299,15 +306,10 @@ void jit_compile(CELL quot, bool relocate) case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { - if(stack_frame) - EMIT(userenv[JIT_EPILOG]); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_DISPATCH]); + EMIT_TAIL_CALL(userenv[JIT_DISPATCH]); i++; - - tail_call = true; break; } else if(jit_ignore_declare_p(untag_object(array),i)) @@ -366,6 +368,12 @@ struct.) */ offset -= size; \ } +#define COUNT_TAIL_CALL(name,scan) { \ + if(stack_frame) COUNT(JIT_EPILOG,scan) \ + tail_call = true; \ + COUNT(name,scan); \ + } + F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) { CELL code_format = compiled_code_format(); @@ -393,15 +401,15 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) word = untag_object(obj); if(word->subprimitive != F) COUNT(word->subprimitive,i) - else if(i == length - 1) + else if(obj == userenv[JIT_EXECUTE_WORD]) { - if(stack_frame) - COUNT(userenv[JIT_EPILOG],i); - - COUNT(userenv[JIT_WORD_JUMP],i) - - tail_call = true; + if(i == length - 1) + COUNT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP],i) + else + COUNT(userenv[JIT_EXECUTE_CALL],i) } + else if(i == length - 1) + COUNT_TAIL_CALL(userenv[JIT_WORD_JUMP],i) else COUNT(userenv[JIT_WORD_CALL],i) break; @@ -424,12 +432,12 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) { if(stack_frame) COUNT(userenv[JIT_EPILOG],i) + tail_call = true; COUNT(userenv[JIT_IF_1],i) COUNT(userenv[JIT_IF_2],i) i += 2; - tail_call = true; break; } else if(jit_fast_dip_p(untag_object(array),i)) @@ -453,22 +461,14 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { - if(stack_frame) - COUNT(userenv[JIT_EPILOG],i) - i++; - - COUNT(userenv[JIT_DISPATCH],i) - - tail_call = true; + COUNT_TAIL_CALL(userenv[JIT_DISPATCH],i) break; } if(jit_ignore_declare_p(untag_object(array),i)) { if(offset == 0) return i; - i++; - break; } default: diff --git a/vm/run.h b/vm/run.h index 2acff2cd5a..3d9775ab6d 100755 --- a/vm/run.h +++ b/vm/run.h @@ -56,6 +56,9 @@ typedef enum { JIT_2DIP, JIT_3DIP_WORD, JIT_3DIP, + JIT_EXECUTE_WORD, + JIT_EXECUTE_JUMP, + JIT_EXECUTE_CALL, STACK_TRACES_ENV = 59, From 76281235e7accd45adcdcabf491a41150f2bcf50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 22:35:19 -0500 Subject: [PATCH 15/83] bootstrap.image: clean up jit-define and define-sub-primitive so that --- basis/bootstrap/image/image.factor | 40 ++++++--- basis/cpu/ppc/bootstrap.factor | 122 ++++++++++++++-------------- basis/cpu/x86/32/bootstrap.factor | 12 +-- basis/cpu/x86/64/bootstrap.factor | 16 ++-- basis/cpu/x86/bootstrap.factor | 125 ++++++++++++++--------------- 5 files changed, 168 insertions(+), 147 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 3a0cc77f61..dea22a7536 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -3,14 +3,13 @@ USING: alien arrays byte-arrays generic assocs hashtables assocs hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser -prettyprint sequences sequences.private strings sbufs -vectors words quotations assocs system layouts splitting -grouping growable classes classes.builtin classes.tuple -classes.tuple.private words.private vocabs -vocabs.loader source-files definitions debugger -quotations.private sequences.private combinators -math.order math.private accessors -slots.private compiler.units fry ; +prettyprint sequences sequences.private strings sbufs vectors words +quotations assocs system layouts splitting grouping growable classes +classes.builtin classes.tuple classes.tuple.private words.private +vocabs vocabs.loader source-files definitions debugger +quotations.private sequences.private combinators math.order +math.private accessors slots.private compiler.units compiler.constants +fry ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -94,13 +93,30 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -: make-jit ( quot rc rt offset -- quad ) - [ [ call( -- ) ] { } make ] 3dip 4array ; +SYMBOL: jit-define-rc +SYMBOL: jit-define-rt +SYMBOL: jit-define-offset -: jit-define ( quot rc rt offset name -- ) +: compute-offset ( -- offset ) + building get length jit-define-rc get rc-absolute-cell = cell 4 ? - ; + +: jit-rel ( rc rt -- ) + jit-define-rt set + jit-define-rc set + compute-offset jit-define-offset set ; + +: make-jit ( quot -- quad ) + [ + call( -- ) + jit-define-rc get + jit-define-rt get + jit-define-offset get 3array + ] { } make prefix ; + +: jit-define ( quot name -- ) [ make-jit ] dip set ; -: define-sub-primitive ( quot rc rt offset word -- ) +: define-sub-primitive ( quot word -- ) [ make-jit ] dip sub-primitives get set-at ; ! The image being constructed; a vector of word-size integers diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 1431d471c1..dffc22982b 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -23,7 +23,7 @@ CONSTANT: rs-reg 30 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 11 6 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI 11 6 profile-count-offset STW @@ -31,50 +31,50 @@ CONSTANT: rs-reg 30 11 11 compiled-header-size ADDI 11 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define +] jit-profiling jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI 6 1 xt-save STW stack-frame 6 LI 6 1 next-save STW 0 1 lr-save stack-frame + STW -] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define +] jit-prolog jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 6 ds-reg 4 STWU -] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define +] jit-push-immediate jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 7 6 0 LWZ 1 7 0 STW -] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define +] jit-save-stack jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 6 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define +] jit-primitive jit-define -[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt jit-rel ] jit-word-call jit-define -[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define +[ 0 B rc-relative-ppc-3 rt-xt ] jit-word-jump jit-define [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI 0 3 \ f tag-number CMPI 2 BEQ - 0 B -] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define + 0 B rc-relative-ppc-3 rt-xt jit-rel +] jit-if-1 jit-define [ - 0 B -] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define + 0 B rc-relative-ppc-3 rt-xt jit-rel +] jit-if-2 jit-define : jit-jump-quot ( -- ) 4 3 quot-xt-offset LWZ @@ -82,14 +82,14 @@ CONSTANT: rs-reg 30 BCTR ; [ - 0 3 LOAD32 + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 6 ds-reg 0 LWZ 6 6 1 SRAWI 3 3 6 ADD 3 3 array-start-offset LWZ ds-reg dup 4 SUBI jit-jump-quot -] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define +] jit-dispatch jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -139,29 +139,29 @@ CONSTANT: rs-reg 30 [ jit->r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-r> -] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define +] jit-dip jit-define [ jit-2>r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-2r> -] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define +] jit-2dip jit-define [ jit-3>r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-3r> -] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define +] jit-3dip jit-define [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI 0 MTLR -] f f f jit-epilog jit-define +] jit-epilog jit-define -[ BLR ] f f f jit-return jit-define +[ BLR ] jit-return jit-define ! Sub-primitives @@ -170,7 +170,7 @@ CONSTANT: rs-reg 30 3 ds-reg 0 LWZ ds-reg dup 4 SUBI jit-jump-quot -] f f f \ (call) define-sub-primitive +] \ (call) define-sub-primitive [ 3 ds-reg 0 LWZ @@ -178,7 +178,7 @@ CONSTANT: rs-reg 30 4 3 word-xt-offset LWZ 4 MTCTR BCTR -] f f f \ (execute) define-sub-primitive +] \ (execute) define-sub-primitive ! Objects [ @@ -186,7 +186,7 @@ CONSTANT: rs-reg 30 3 3 tag-mask get ANDI 3 3 tag-bits get SLWI 3 ds-reg 0 STW -] f f f \ tag define-sub-primitive +] \ tag define-sub-primitive [ 3 ds-reg 0 LWZ @@ -195,25 +195,25 @@ CONSTANT: rs-reg 30 4 4 0 0 31 tag-bits get - RLWINM 4 3 3 LWZX 3 ds-reg 0 STW -] f f f \ slot define-sub-primitive +] \ slot define-sub-primitive ! Shufflers [ ds-reg dup 4 SUBI -] f f f \ drop define-sub-primitive +] \ drop define-sub-primitive [ ds-reg dup 8 SUBI -] f f f \ 2drop define-sub-primitive +] \ 2drop define-sub-primitive [ ds-reg dup 12 SUBI -] f f f \ 3drop define-sub-primitive +] \ 3drop define-sub-primitive [ 3 ds-reg 0 LWZ 3 ds-reg 4 STWU -] f f f \ dup define-sub-primitive +] \ dup define-sub-primitive [ 3 ds-reg 0 LWZ @@ -221,7 +221,7 @@ CONSTANT: rs-reg 30 ds-reg dup 8 ADDI 3 ds-reg 0 STW 4 ds-reg -4 STW -] f f f \ 2dup define-sub-primitive +] \ 2dup define-sub-primitive [ 3 ds-reg 0 LWZ @@ -231,36 +231,36 @@ CONSTANT: rs-reg 30 3 ds-reg 0 STW 4 ds-reg -4 STW 5 ds-reg -8 STW -] f f f \ 3dup define-sub-primitive +] \ 3dup define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI 3 ds-reg 0 STW -] f f f \ nip define-sub-primitive +] \ nip define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg dup 8 SUBI 3 ds-reg 0 STW -] f f f \ 2nip define-sub-primitive +] \ 2nip define-sub-primitive [ 3 ds-reg -4 LWZ 3 ds-reg 4 STWU -] f f f \ over define-sub-primitive +] \ over define-sub-primitive [ 3 ds-reg -8 LWZ 3 ds-reg 4 STWU -] f f f \ pick define-sub-primitive +] \ pick define-sub-primitive [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ 4 ds-reg 0 STW 3 ds-reg 4 STWU -] f f f \ dupd define-sub-primitive +] \ dupd define-sub-primitive [ 3 ds-reg 0 LWZ @@ -268,21 +268,21 @@ CONSTANT: rs-reg 30 3 ds-reg 4 STWU 4 ds-reg -4 STW 3 ds-reg -8 STW -] f f f \ tuck define-sub-primitive +] \ tuck define-sub-primitive [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ 3 ds-reg -4 STW 4 ds-reg 0 STW -] f f f \ swap define-sub-primitive +] \ swap define-sub-primitive [ 3 ds-reg -4 LWZ 4 ds-reg -8 LWZ 3 ds-reg -8 STW 4 ds-reg -4 STW -] f f f \ swapd define-sub-primitive +] \ swapd define-sub-primitive [ 3 ds-reg 0 LWZ @@ -291,7 +291,7 @@ CONSTANT: rs-reg 30 4 ds-reg -8 STW 3 ds-reg -4 STW 5 ds-reg 0 STW -] f f f \ rot define-sub-primitive +] \ rot define-sub-primitive [ 3 ds-reg 0 LWZ @@ -300,9 +300,9 @@ CONSTANT: rs-reg 30 3 ds-reg -8 STW 5 ds-reg -4 STW 4 ds-reg 0 STW -] f f f \ -rot define-sub-primitive +] \ -rot define-sub-primitive -[ jit->r ] f f f \ load-local define-sub-primitive +[ jit->r ] \ load-local define-sub-primitive ! Comparisons : jit-compare ( insn -- ) @@ -336,7 +336,7 @@ CONSTANT: rs-reg 30 2 BNE 1 tag-fixnum 4 LI 4 ds-reg 0 STW -] f f f \ both-fixnums? define-sub-primitive +] \ both-fixnums? define-sub-primitive : jit-math ( insn -- ) 3 ds-reg 0 LWZ @@ -344,9 +344,9 @@ CONSTANT: rs-reg 30 [ 5 3 4 ] dip execute( dst src1 src2 -- ) 5 ds-reg 0 STW ; -[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive +[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive -[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive +[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -354,20 +354,20 @@ CONSTANT: rs-reg 30 4 4 tag-bits get SRAWI 5 3 4 MULLW 5 ds-reg 0 STW -] f f f \ fixnum*fast define-sub-primitive +] \ fixnum*fast define-sub-primitive -[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive +[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive -[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive +[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive -[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive +[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive [ 3 ds-reg 0 LWZ 3 3 NOT 3 3 tag-mask get XORI 3 ds-reg 0 STW -] f f f \ fixnum-bitnot define-sub-primitive +] \ fixnum-bitnot define-sub-primitive [ 3 ds-reg 0 LWZ @@ -382,7 +382,7 @@ CONSTANT: rs-reg 30 2 BGT 5 7 MR 5 ds-reg 0 STW -] f f f \ fixnum-shift-fast define-sub-primitive +] \ fixnum-shift-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -392,7 +392,7 @@ CONSTANT: rs-reg 30 6 5 3 MULLW 7 6 4 SUBF 7 ds-reg 0 STW -] f f f \ fixnum-mod define-sub-primitive +] \ fixnum-mod define-sub-primitive [ 3 ds-reg 0 LWZ @@ -401,7 +401,7 @@ CONSTANT: rs-reg 30 5 4 3 DIVW 5 5 tag-bits get SLWI 5 ds-reg 0 STW -] f f f \ fixnum/i-fast define-sub-primitive +] \ fixnum/i-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -412,20 +412,20 @@ CONSTANT: rs-reg 30 5 5 tag-bits get SLWI 5 ds-reg -4 STW 7 ds-reg 0 STW -] f f f \ fixnum/mod-fast define-sub-primitive +] \ fixnum/mod-fast define-sub-primitive [ 3 ds-reg 0 LWZ 3 3 1 SRAWI rs-reg 3 3 LWZX 3 ds-reg 0 STW -] f f f \ get-local define-sub-primitive +] \ get-local define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg ds-reg 4 SUBI 3 3 1 SRAWI rs-reg 3 rs-reg SUBF -] f f f \ drop-locals define-sub-primitive +] \ drop-locals define-sub-primitive [ "bootstrap.ppc" forget-vocab ] with-compilation-unit diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 5d88f699b8..be21344815 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -22,13 +22,15 @@ IN: bootstrap.x86 : rex-length ( -- n ) 0 ; [ - temp0 0 [] MOV ! load stack_chain - temp0 [] stack-reg MOV ! save stack pointer -] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define + ! load stack_chain + temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel + ! save stack pointer + temp0 [] stack-reg MOV +] jit-save-stack jit-define [ - (JMP) drop -] rc-relative rt-primitive 1 jit-primitive jit-define + (JMP) drop rc-relative rt-primitive jit-rel +] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index ddf5791009..8d1ed086e7 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -20,15 +20,19 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - temp0 0 MOV ! load stack_chain + ! load stack_chain + temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV - temp0 [] stack-reg MOV ! save stack pointer -] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define + ! save stack pointer + temp0 [] stack-reg MOV +] jit-save-stack jit-define [ - temp1 0 MOV ! load XT - temp1 JMP ! go -] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define + ! load XT + temp1 0 MOV rc-absolute-cell rt-primitive jit-rel + ! go + temp1 JMP +] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index e1cbcc5d97..279deb5834 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -12,7 +12,7 @@ big-endian off [ ! Load word - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! Bump profiling counter temp0 profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code @@ -21,35 +21,35 @@ big-endian off temp0 compiled-header-size ADD ! Jump to XT temp0 JMP -] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define +] jit-profiling jit-define [ ! load XT - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-this jit-rel ! save stack frame size stack-frame-size PUSH ! push XT temp0 PUSH ! alignment stack-reg stack-frame-size 3 bootstrap-cells - SUB -] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define +] jit-prolog jit-define [ ! load literal - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! increment datastack pointer ds-reg bootstrap-cell ADD ! store literal on datastack ds-reg [] temp0 MOV -] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define +] jit-push-immediate jit-define [ - f JMP -] rc-relative rt-xt 1 jit-word-jump jit-define + f JMP rc-relative rt-xt jit-rel +] jit-word-jump jit-define [ - f CALL -] rc-relative rt-xt 1 jit-word-call jit-define + f CALL rc-relative rt-xt jit-rel +] jit-word-call jit-define [ ! load boolean @@ -59,17 +59,17 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE -] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define + f JNE rc-relative rt-xt jit-rel +] jit-if-1 jit-define [ ! jump to false branch if equal - f JMP -] rc-relative rt-xt 1 jit-if-2 jit-define + f JMP rc-relative rt-xt jit-rel +] jit-if-2 jit-define [ ! load dispatch table - temp1 0 MOV + temp1 0 MOV rc-absolute-cell rt-immediate jit-rel ! load index temp0 ds-reg [] MOV ! turn it into an array offset @@ -83,7 +83,7 @@ big-endian off ! execute branch. the quot must be in arg, since it might ! not be compiled yet arg quot-xt-offset [+] JMP -] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define +] jit-dispatch jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD @@ -135,21 +135,21 @@ big-endian off [ jit->r - f CALL + f CALL rc-relative rt-xt jit-rel jit-r> -] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define +] jit-dip jit-define [ jit-2>r - f CALL + f CALL rc-relative rt-xt jit-rel jit-2r> -] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define +] jit-2dip jit-define [ jit-3>r - f CALL + f CALL rc-relative rt-xt jit-rel jit-3r> -] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define +] jit-3dip jit-define : prepare-(execute) ( -- operand ) ! load from stack @@ -159,16 +159,16 @@ big-endian off ! execute word temp0 word-xt-offset [+] ; -[ prepare-(execute) JMP ] f f f jit-execute-jump jit-define +[ prepare-(execute) JMP ] jit-execute-jump jit-define -[ prepare-(execute) CALL ] f f f jit-execute-call jit-define +[ prepare-(execute) CALL ] jit-execute-call jit-define [ ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD -] f f f jit-epilog jit-define +] jit-epilog jit-define -[ 0 RET ] f f f jit-return jit-define +[ 0 RET ] jit-return jit-define ! Sub-primitives @@ -180,7 +180,7 @@ big-endian off ds-reg bootstrap-cell SUB ! call quotation arg quot-xt-offset [+] JMP -] f f f \ (call) define-sub-primitive +] \ (call) define-sub-primitive ! Objects [ @@ -192,7 +192,7 @@ big-endian off temp0 tag-bits get SHL ! push to stack ds-reg [] temp0 MOV -] f f f \ tag define-sub-primitive +] \ tag define-sub-primitive [ ! load slot number @@ -210,26 +210,26 @@ big-endian off temp0 temp1 temp0 [+] MOV ! push to stack ds-reg [] temp0 MOV -] f f f \ slot define-sub-primitive +] \ slot define-sub-primitive ! Shufflers [ ds-reg bootstrap-cell SUB -] f f f \ drop define-sub-primitive +] \ drop define-sub-primitive [ ds-reg 2 bootstrap-cells SUB -] f f f \ 2drop define-sub-primitive +] \ 2drop define-sub-primitive [ ds-reg 3 bootstrap-cells SUB -] f f f \ 3drop define-sub-primitive +] \ 3drop define-sub-primitive [ temp0 ds-reg [] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ dup define-sub-primitive +] \ dup define-sub-primitive [ temp0 ds-reg [] MOV @@ -237,7 +237,7 @@ big-endian off ds-reg 2 bootstrap-cells ADD ds-reg [] temp0 MOV ds-reg bootstrap-cell neg [+] temp1 MOV -] f f f \ 2dup define-sub-primitive +] \ 2dup define-sub-primitive [ temp0 ds-reg [] MOV @@ -247,31 +247,31 @@ big-endian off ds-reg [] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -2 bootstrap-cells [+] temp3 MOV -] f f f \ 3dup define-sub-primitive +] \ 3dup define-sub-primitive [ temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB ds-reg [] temp0 MOV -] f f f \ nip define-sub-primitive +] \ nip define-sub-primitive [ temp0 ds-reg [] MOV ds-reg 2 bootstrap-cells SUB ds-reg [] temp0 MOV -] f f f \ 2nip define-sub-primitive +] \ 2nip define-sub-primitive [ temp0 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ over define-sub-primitive +] \ over define-sub-primitive [ temp0 ds-reg -2 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ pick define-sub-primitive +] \ pick define-sub-primitive [ temp0 ds-reg [] MOV @@ -279,7 +279,7 @@ big-endian off ds-reg [] temp1 MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ dupd define-sub-primitive +] \ dupd define-sub-primitive [ temp0 ds-reg [] MOV @@ -288,21 +288,21 @@ big-endian off ds-reg [] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -2 bootstrap-cells [+] temp0 MOV -] f f f \ tuck define-sub-primitive +] \ tuck define-sub-primitive [ temp0 ds-reg [] MOV temp1 ds-reg bootstrap-cell neg [+] MOV ds-reg bootstrap-cell neg [+] temp0 MOV ds-reg [] temp1 MOV -] f f f \ swap define-sub-primitive +] \ swap define-sub-primitive [ temp0 ds-reg -1 bootstrap-cells [+] MOV temp1 ds-reg -2 bootstrap-cells [+] MOV ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV -] f f f \ swapd define-sub-primitive +] \ swapd define-sub-primitive [ temp0 ds-reg [] MOV @@ -311,7 +311,7 @@ big-endian off ds-reg -2 bootstrap-cells [+] temp1 MOV ds-reg -1 bootstrap-cells [+] temp0 MOV ds-reg [] temp3 MOV -] f f f \ rot define-sub-primitive +] \ rot define-sub-primitive [ temp0 ds-reg [] MOV @@ -320,14 +320,14 @@ big-endian off ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -1 bootstrap-cells [+] temp3 MOV ds-reg [] temp1 MOV -] f f f \ -rot define-sub-primitive +] \ -rot define-sub-primitive -[ jit->r ] f f f \ load-local define-sub-primitive +[ jit->r ] \ load-local define-sub-primitive ! Comparisons : jit-compare ( insn -- ) ! load t - temp3 0 MOV + temp3 0 MOV rc-absolute-cell rt-immediate jit-rel ! load f temp1 \ f tag-number MOV ! load first value @@ -342,8 +342,7 @@ big-endian off ds-reg [] temp1 MOV ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip - define-sub-primitive ; + [ [ jit-compare ] curry ] dip define-sub-primitive ; \ CMOVE \ eq? define-jit-compare \ CMOVGE \ fixnum>= define-jit-compare @@ -360,9 +359,9 @@ big-endian off ! compute result [ ds-reg [] temp0 ] dip execute( dst src -- ) ; -[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive +[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive -[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive +[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive [ ! load second input @@ -377,20 +376,20 @@ big-endian off temp0 temp1 IMUL2 ! push result ds-reg [] temp1 MOV -] f f f \ fixnum*fast define-sub-primitive +] \ fixnum*fast define-sub-primitive -[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive +[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive -[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive +[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive -[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive +[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive [ ! complement ds-reg [] NOT ! clear tag bits ds-reg [] tag-mask get XOR -] f f f \ fixnum-bitnot define-sub-primitive +] \ fixnum-bitnot define-sub-primitive [ ! load shift count @@ -414,7 +413,7 @@ big-endian off temp1 temp3 CMOVGE ! push to stack ds-reg [] temp1 MOV -] f f f \ fixnum-shift-fast define-sub-primitive +] \ fixnum-shift-fast define-sub-primitive : jit-fixnum-/mod ( -- ) ! load second parameter @@ -434,7 +433,7 @@ big-endian off ds-reg bootstrap-cell SUB ! push to stack ds-reg [] mod-arg MOV -] f f f \ fixnum-mod define-sub-primitive +] \ fixnum-mod define-sub-primitive [ jit-fixnum-/mod @@ -444,7 +443,7 @@ big-endian off div-arg tag-bits get SHL ! push to stack ds-reg [] div-arg MOV -] f f f \ fixnum/i-fast define-sub-primitive +] \ fixnum/i-fast define-sub-primitive [ jit-fixnum-/mod @@ -453,7 +452,7 @@ big-endian off ! push to stack ds-reg [] mod-arg MOV ds-reg bootstrap-cell neg [+] div-arg MOV -] f f f \ fixnum/mod-fast define-sub-primitive +] \ fixnum/mod-fast define-sub-primitive [ temp0 ds-reg [] MOV @@ -464,7 +463,7 @@ big-endian off temp1 1 tag-fixnum MOV temp0 temp1 CMOVE ds-reg [] temp0 MOV -] f f f \ both-fixnums? define-sub-primitive +] \ both-fixnums? define-sub-primitive [ ! load local number @@ -475,7 +474,7 @@ big-endian off temp0 rs-reg temp0 [+] MOV ! push to stack ds-reg [] temp0 MOV -] f f f \ get-local define-sub-primitive +] \ get-local define-sub-primitive [ ! load local count @@ -486,6 +485,6 @@ big-endian off fixnum>slot@ ! decrement retain stack pointer rs-reg temp0 SUB -] f f f \ drop-locals define-sub-primitive +] \ drop-locals define-sub-primitive [ "bootstrap.x86" forget-vocab ] with-compilation-unit From 8ea3db9eefe1e0380033fed24218bb59d68f6f17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 22:35:30 -0500 Subject: [PATCH 16/83] Get rid of a 'rot' --- basis/compiler/codegen/fixup/fixup.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 3a047a8d39..5a186f8a20 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -25,7 +25,7 @@ TUPLE: label-fixup label class ; M: label-fixup fixup* dup class>> rc-absolute? [ "Absolute labels not supported" throw ] when - [ label>> ] [ class>> ] bi compiled-offset 4 - rot + [ class>> ] [ label>> ] bi compiled-offset 4 - swap 3array label-table get push ; TUPLE: rel-fixup class type ; From 89eccddde7643a8c30fe3a45c74a2ea39ad99482 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 22:35:51 -0500 Subject: [PATCH 17/83] quotations.c: fix quot_code_offset_to_scan --- vm/quotations.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/quotations.c b/vm/quotations.c index 6291bd6839..7835d46e14 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -368,10 +368,10 @@ struct.) */ offset -= size; \ } -#define COUNT_TAIL_CALL(name,scan) { \ - if(stack_frame) COUNT(JIT_EPILOG,scan) \ - tail_call = true; \ - COUNT(name,scan); \ +#define COUNT_TAIL_CALL(name,scan) { \ + if(stack_frame) COUNT(userenv[JIT_EPILOG],scan) \ + tail_call = true; \ + COUNT(name,scan); \ } F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) From 7e84daf0f1515b798ff57387d7ad8e60366e27d1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 02:42:37 -0500 Subject: [PATCH 18/83] Move (execute) to kernel.private --- basis/bootstrap/image/image.factor | 2 +- basis/compiler/codegen/fixup/fixup.factor | 2 +- basis/compiler/compiler-docs.factor | 2 +- basis/cpu/ppc/bootstrap.factor | 2 +- basis/cpu/x86/bootstrap.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 4 ++-- basis/tools/deploy/backend/backend.factor | 11 +++++------ basis/tools/deploy/shaker/shaker.factor | 2 +- core/bootstrap/primitives.factor | 3 +-- core/generic/single/single.factor | 7 +------ core/kernel/kernel-docs.factor | 14 ++++++++++++++ core/words/words-docs.factor | 11 +---------- core/words/words.factor | 6 +++--- 13 files changed, 33 insertions(+), 35 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index dea22a7536..91aafa9f92 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -5,7 +5,7 @@ hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts splitting grouping growable classes -classes.builtin classes.tuple classes.tuple.private words.private +classes.builtin classes.tuple classes.tuple.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors slots.private compiler.units compiler.constants diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 5a186f8a20..e22242d48e 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -3,7 +3,7 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables io.binary kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts -system combinators math.bitwise words.private math.order +system combinators math.bitwise math.order accessors growable cpu.architecture compiler.constants ; IN: compiler.codegen.fixup diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index b96d5e573a..49511fe579 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,7 +1,7 @@ USING: assocs compiler.cfg.builder compiler.cfg.optimizer compiler.errors compiler.tree.builder compiler.tree.optimizer compiler.units help.markup help.syntax io parser quotations -sequences words words.private ; +sequences words ; IN: compiler HELP: enable-compiler diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index dffc22982b..ef88fe79fd 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units -compiler.constants math math.private layouts words words.private +compiler.constants math math.private layouts words vocabs slots.private locals.backend ; IN: bootstrap.ppc diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 279deb5834..dd17ef4186 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -3,7 +3,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler layouts compiler.units math math.private compiler.constants vocabs slots.private words -words.private locals.backend ; +locals.backend ; IN: bootstrap.x86 big-endian off diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e7693b9ecd..56c59c8759 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -9,8 +9,8 @@ quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions -words.private assocs summary compiler.units system.private -combinators locals locals.backend locals.types words.private +assocs summary compiler.units system.private +combinators locals locals.backend locals.types quotations.private combinators.private stack-checker.values generic.single generic.single.private alien.libraries diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 6ca54ca36b..b74548a65f 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -3,12 +3,11 @@ USING: namespaces make continuations.private kernel.private init assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes -summary layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.files io.files.temp io.pathnames -io.directories io.directories.hierarchy io.backend quotations -io.launcher words.private tools.deploy.config -tools.deploy.config.editor bootstrap.image io.encodings.utf8 -destructors accessors hashtables ; +summary layouts vocabs.loader prettyprint.config prettyprint debugger +io.streams.c io.files io.files.temp io.pathnames io.directories +io.directories.hierarchy io.backend quotations io.launcher +tools.deploy.config tools.deploy.config.editor bootstrap.image +io.encodings.utf8 destructors accessors hashtables ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e23e1b092d..9d489cb9a8 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io.backend io.streams.c init fry namespaces make assocs kernel parser lexer strings.parser vocabs -sequences words words.private memory kernel.private +sequences words memory kernel.private continuations io vocabs.loader system strings sets vectors quotations byte-arrays sorting compiler.units definitions generic generic.standard tools.deploy.config ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 7ec1092293..62f23f206d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -98,7 +98,6 @@ bootstrapping? on "threads.private" "tools.profiler.private" "words" - "words.private" "vectors" "vectors.private" } [ create-vocab drop ] each @@ -339,7 +338,7 @@ tuple [ create dup 1quotation ] dip define-declared ; { - { "(execute)" "words.private" (( word -- )) } + { "(execute)" "kernel.private" (( word -- )) } { "(call)" "kernel.private" (( quot -- )) } { "both-fixnums?" "math.private" (( x y -- ? )) } { "fixnum+fast" "math.private" (( x y -- z )) } diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 5cb93aae08..8d07132c8b 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -3,8 +3,7 @@ USING: accessors arrays assocs classes classes.algebra combinators definitions generic hashtables kernel kernel.private layouts make math namespaces quotations -sequences words generic.single.private words.private -effects make ; +sequences words generic.single.private effects make ; IN: generic.single ERROR: no-method object generic ; @@ -127,13 +126,9 @@ TUPLE: tag-dispatch-engine methods ; C: tag-dispatch-engine : ( assoc -- engine ) - dup keys [ not ] filter [ "FOO" throw ] unless-empty flatten-methods - dup keys [ not ] filter [ "FOO1" throw ] unless-empty convert-tuple-methods - dup keys [ not ] filter [ "FOO2" throw ] unless-empty convert-hi-tag-methods - dup keys [ not ] filter [ "FOO3" throw ] unless-empty ; ! ! ! Compile engine ! ! ! diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1d8c09a9b2..e67e2bc0dd 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -183,6 +183,20 @@ HELP: either? { $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" } } ; +HELP: execute +{ $values { "word" word } } +{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } +{ $examples + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } +} ; + +{ execute POSTPONE: execute( } related-words + +HELP: (execute) +{ $values { "word" word } } +{ $description "Executes a word without checking if it is a word first." } +{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is unsafe. Calling with a parameter that is not a word will crash Factor. Use " { $link execute } " instead." } ; + HELP: call { $values { "callable" callable } } { $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 94609a06e5..3725086f70 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -1,5 +1,5 @@ USING: definitions help.markup help.syntax kernel parser -kernel.private words.private vocabs classes quotations +kernel.private vocabs classes quotations strings effects compiler.units ; IN: words @@ -163,15 +163,6 @@ $nl ABOUT: "words" -HELP: execute ( word -- ) -{ $values { "word" word } } -{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } -{ $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } -} ; - -{ execute POSTPONE: execute( } related-words - HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index 894b671494..7ee9a7ca65 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions graphs assocs kernel -kernel.private slots.private math namespaces sequences strings -vectors sbufs quotations assocs hashtables sorting words.private -vocabs math.order sets ; +kernel.private kernel.private slots.private math namespaces sequences +strings vectors sbufs quotations assocs hashtables sorting vocabs +math.order sets ; IN: words : word ( -- word ) \ word get-global ; From 63fff0a83248466640fa7396ee8dccdb433b9240 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 07:00:48 -0500 Subject: [PATCH 19/83] Clean up VM's growable array implementation, and non-optimizing compiler --- vm/code_block.c | 3 +- vm/data_gc.c | 1 + vm/data_gc.h | 2 + vm/data_heap.c | 1 + vm/local_roots.h | 4 +- vm/quotations.c | 152 ++++++++++++++++++++++++----------------------- vm/types.c | 56 +++++++++-------- vm/types.h | 75 ++++++++++++++++------- 8 files changed, 170 insertions(+), 124 deletions(-) diff --git a/vm/code_block.c b/vm/code_block.c index 8dda8bc16e..c04e13d691 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -224,7 +224,8 @@ void mark_object_code_block(CELL scan) { case WORD_TYPE: word = (F_WORD *)scan; - mark_code_block(word->code); + if(word->code) + mark_code_block(word->code); if(word->profiling) mark_code_block(word->profiling); break; diff --git a/vm/data_gc.c b/vm/data_gc.c index 50f38bc881..0b210310a2 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -550,6 +550,7 @@ void primitive_gc_stats(void) GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); dpush(stats); } diff --git a/vm/data_gc.h b/vm/data_gc.h index 52d8b603ad..b59cb0eb9e 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -82,8 +82,10 @@ registers) does not run out of memory */ * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ +int count; INLINE void *allot_object(CELL type, CELL a) { + if(!gc_off) { if(count++ % 100 == 0) { printf("!\n"); gc(); } } CELL *object; if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a) diff --git a/vm/data_heap.c b/vm/data_heap.c index eb8add544e..44232ab6b0 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -366,6 +366,7 @@ CELL find_all_words(void) gc_off = false; GROWABLE_ARRAY_TRIM(words); + GROWABLE_ARRAY_DONE(words); return words; } diff --git a/vm/local_roots.h b/vm/local_roots.h index e852f9e54d..6d9658dbd3 100644 --- a/vm/local_roots.h +++ b/vm/local_roots.h @@ -19,10 +19,10 @@ CELL gc_locals; DEFPUSHPOP(gc_local_,gc_locals) -#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj) +#define REGISTER_ROOT(obj) gc_local_push((CELL)&(obj)) #define UNREGISTER_ROOT(obj) \ { \ - if(gc_local_pop() != (CELL)&obj) \ + if(gc_local_pop() != (CELL)&(obj)) \ critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \ } diff --git a/vm/quotations.c b/vm/quotations.c index 7835d46e14..48979256ff 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -89,45 +89,6 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; } -F_ARRAY *code_to_emit(CELL code) -{ - return untag_object(array_nth(untag_object(code),0)); -} - -F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p) -{ - F_ARRAY *quadruple = untag_object(code); - CELL rel_class = array_nth(quadruple,1); - CELL rel_type = array_nth(quadruple,2); - CELL offset = array_nth(quadruple,3); - - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (to_fixnum(rel_type) << 28) - | (to_fixnum(rel_class) << 24) - | ((code_length + to_fixnum(offset)) * code_format); - } -} - -#define EMIT(name) { \ - bool rel_p; \ - F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \ - if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \ - GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \ - } - -#define EMIT_TAIL_CALL(name) { \ - if(stack_frame) EMIT(userenv[JIT_EPILOG]); \ - tail_call = true; \ - EMIT(name); \ - } - bool jit_stack_frame_p(F_ARRAY *array) { F_FIXNUM length = array_capacity(array); @@ -164,6 +125,53 @@ void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) quot->compiledp = T; } +F_ARRAY *code_to_emit(CELL template) +{ + return untag_object(array_nth(untag_object(template),0)); +} + +F_REL rel_to_emit(CELL template, CELL code_format, CELL code_length, bool *rel_p) +{ + F_ARRAY *quadruple = untag_object(template); + CELL rel_class = array_nth(quadruple,1); + CELL rel_type = array_nth(quadruple,2); + CELL offset = array_nth(quadruple,3); + + if(rel_class == F) + { + *rel_p = false; + return 0; + } + else + { + *rel_p = true; + return (to_fixnum(rel_type) << 28) + | (to_fixnum(rel_class) << 24) + | ((code_length + to_fixnum(offset)) * code_format); + } +} + +static void jit_emit(CELL template, CELL code_format, + F_GROWABLE_ARRAY *code, F_GROWABLE_BYTE_ARRAY *relocation) +{ + REGISTER_ROOT(template); + bool rel_p; + F_REL rel = rel_to_emit(template,code_format,code->count,&rel_p); + if(rel_p) growable_byte_array_append(relocation,&rel,sizeof(F_REL)); + growable_array_append(code,code_to_emit(template)); + UNREGISTER_ROOT(template); +} + +#define EMIT(template) { jit_emit(template,code_format,&code_g,&relocation_g); } + +#define EMIT_LITERAL GROWABLE_ARRAY_ADD(literals,obj); + +#define EMIT_TAIL_CALL(template) { \ + if(stack_frame) EMIT(userenv[JIT_EPILOG]); \ + tail_call = true; \ + EMIT(template); \ + } + /* Might GC */ void jit_compile(CELL quot, bool relocate) { @@ -172,19 +180,14 @@ void jit_compile(CELL quot, bool relocate) CELL code_format = compiled_code_format(); - REGISTER_ROOT(quot); - CELL array = untag_quotation(quot)->array; + + REGISTER_ROOT(quot); REGISTER_ROOT(array); GROWABLE_ARRAY(code); - REGISTER_ROOT(code); - GROWABLE_BYTE_ARRAY(relocation); - REGISTER_ROOT(relocation); - GROWABLE_ARRAY(literals); - REGISTER_ROOT(literals); if(stack_traces_p()) GROWABLE_ARRAY_ADD(literals,quot); @@ -192,7 +195,7 @@ void jit_compile(CELL quot, bool relocate) bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - EMIT(userenv[JIT_PROLOG]); + EMIT(userenv[JIT_PROLOG]) CELL i; CELL length = array_capacity(untag_object(array)); @@ -212,12 +215,12 @@ void jit_compile(CELL quot, bool relocate) /* Intrinsics */ if(word->subprimitive != F) { + REGISTER_UNTAGGED(word); if(array_nth(untag_object(word->subprimitive),1) != F) - { GROWABLE_ARRAY_ADD(literals,T); - } + UNREGISTER_UNTAGGED(word); - EMIT(word->subprimitive); + EMIT(word->subprimitive) } else if(obj == userenv[JIT_EXECUTE_WORD]) { @@ -228,7 +231,7 @@ void jit_compile(CELL quot, bool relocate) } else { - GROWABLE_ARRAY_ADD(literals,obj); + EMIT_LITERAL if(i == length - 1) EMIT_TAIL_CALL(userenv[JIT_WORD_JUMP]) @@ -239,14 +242,14 @@ void jit_compile(CELL quot, bool relocate) case WRAPPER_TYPE: wrapper = untag_object(obj); GROWABLE_ARRAY_ADD(literals,wrapper->object); - EMIT(userenv[JIT_PUSH_IMMEDIATE]); + EMIT(userenv[JIT_PUSH_IMMEDIATE]) break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - EMIT(userenv[JIT_SAVE_STACK]); - GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[JIT_PRIMITIVE]); + EMIT(userenv[JIT_SAVE_STACK]) + EMIT_LITERAL + EMIT(userenv[JIT_PRIMITIVE]) i++; @@ -257,7 +260,7 @@ void jit_compile(CELL quot, bool relocate) if(jit_fast_if_p(untag_object(array),i)) { if(stack_frame) - EMIT(userenv[JIT_EPILOG]); + EMIT(userenv[JIT_EPILOG]) tail_call = true; @@ -265,9 +268,9 @@ void jit_compile(CELL quot, bool relocate) jit_compile(array_nth(untag_object(array),i + 1),relocate); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_IF_1]); + EMIT(userenv[JIT_IF_1]) GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); - EMIT(userenv[JIT_IF_2]); + EMIT(userenv[JIT_IF_2]) i += 2; @@ -277,8 +280,8 @@ void jit_compile(CELL quot, bool relocate) { jit_compile(obj,relocate); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_DIP]); + EMIT_LITERAL + EMIT(userenv[JIT_DIP]) i++; break; @@ -287,8 +290,8 @@ void jit_compile(CELL quot, bool relocate) { jit_compile(obj,relocate); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_2DIP]); + EMIT_LITERAL + EMIT(userenv[JIT_2DIP]) i++; break; @@ -297,8 +300,8 @@ void jit_compile(CELL quot, bool relocate) { jit_compile(obj,relocate); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_3DIP]); + EMIT_LITERAL + EMIT(userenv[JIT_3DIP]) i++; break; @@ -306,8 +309,8 @@ void jit_compile(CELL quot, bool relocate) case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT_TAIL_CALL(userenv[JIT_DISPATCH]); + EMIT_LITERAL + EMIT_TAIL_CALL(userenv[JIT_DISPATCH]) i++; break; @@ -318,8 +321,8 @@ void jit_compile(CELL quot, bool relocate) break; } default: - GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[JIT_PUSH_IMMEDIATE]); + EMIT_LITERAL + EMIT(userenv[JIT_PUSH_IMMEDIATE]) break; } } @@ -327,14 +330,14 @@ void jit_compile(CELL quot, bool relocate) if(!tail_call) { if(stack_frame) - EMIT(userenv[JIT_EPILOG]); + EMIT(userenv[JIT_EPILOG]) - EMIT(userenv[JIT_RETURN]); + EMIT(userenv[JIT_RETURN]) } - GROWABLE_ARRAY_TRIM(code); GROWABLE_ARRAY_TRIM(literals); GROWABLE_BYTE_ARRAY_TRIM(relocation); + GROWABLE_ARRAY_TRIM(code); F_CODE_BLOCK *compiled = add_code_block( QUOTATION_TYPE, @@ -348,9 +351,10 @@ void jit_compile(CELL quot, bool relocate) if(relocate) relocate_code_block(compiled); - UNREGISTER_ROOT(literals); - UNREGISTER_ROOT(relocation); - UNREGISTER_ROOT(code); + GROWABLE_ARRAY_DONE(literals); + GROWABLE_BYTE_ARRAY_DONE(relocation); + GROWABLE_ARRAY_DONE(code); + UNREGISTER_ROOT(array); UNREGISTER_ROOT(quot); } diff --git a/vm/types.c b/vm/types.c index 889de38016..1985f51567 100755 --- a/vm/types.c +++ b/vm/types.c @@ -192,41 +192,45 @@ void primitive_resize_array(void) dpush(tag_object(reallot_array(array,capacity))); } -F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) +void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) { + F_ARRAY *underlying = untag_object(array->array); REGISTER_ROOT(elt); - if(*result_count == array_capacity(result)) + if(array->count == array_capacity(underlying)) { - result = reallot_array(result,*result_count * 2); + underlying = reallot_array(underlying,array->count * 2); + array->array = tag_object(underlying); } UNREGISTER_ROOT(elt); - set_array_nth(result,*result_count,elt); - (*result_count)++; - - return result; + set_array_nth(underlying,array->count++,elt); } -F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) +void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) { REGISTER_UNTAGGED(elts); - CELL elts_size = array_capacity(elts); - CELL new_size = *result_count + elts_size; + F_ARRAY *underlying = untag_object(array->array); - if(new_size >= array_capacity(result)) - result = reallot_array(result,new_size * 2); + CELL elts_size = array_capacity(elts); + CELL new_size = array->count + elts_size; + + if(new_size >= array_capacity(underlying)) + { + underlying = reallot_array(underlying,new_size * 2); + array->array = tag_object(underlying); + } UNREGISTER_UNTAGGED(elts); - write_barrier((CELL)result); + write_barrier((CELL)array->array); - memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS); + memcpy((void *)AREF(underlying,array->count), + (void *)AREF(elts,0), + elts_size * CELLS); - *result_count += elts_size; - - return result; + array->count += elts_size; } /* Byte arrays */ @@ -283,18 +287,20 @@ void primitive_resize_byte_array(void) dpush(tag_object(reallot_byte_array(array,capacity))); } -F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count) +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) { - CELL new_size = *result_count + len; + CELL new_size = array->count + len; + F_BYTE_ARRAY *underlying = untag_object(array->array); - if(new_size >= byte_array_capacity(result)) - result = reallot_byte_array(result,new_size * 2); + if(new_size >= byte_array_capacity(underlying)) + { + underlying = reallot_byte_array(underlying,new_size * 2); + array->array = tag_object(underlying); + } - memcpy((void *)BREF(result,*result_count),elts,len); + memcpy((void *)BREF(underlying,array->count),elts,len); - *result_count = new_size; - - return result; + array->count += len; } /* Tuples */ diff --git a/vm/types.h b/vm/types.h index 2775f57bb2..01176d6191 100755 --- a/vm/types.h +++ b/vm/types.h @@ -77,12 +77,6 @@ INLINE CELL tag_tuple(F_TUPLE *tuple) return RETAG(tuple,TUPLE_TYPE); } -INLINE F_TUPLE *untag_tuple(CELL object) -{ - type_check(TUPLE_TYPE,object); - return untag_object(object); -} - INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) { CELL size = untag_fixnum_fast(layout->size); @@ -165,32 +159,69 @@ void primitive_word_xt(void); void primitive_wrapper(void); /* Macros to simulate a vector in C */ -#define GROWABLE_ARRAY(result) \ - CELL result##_count = 0; \ - CELL result = tag_object(allot_array(ARRAY_TYPE,100,F)) +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_ARRAY; -F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count); +INLINE F_GROWABLE_ARRAY make_growable_array(void) +{ + F_GROWABLE_ARRAY result; + result.count = 0; + result.array = tag_object(allot_array(ARRAY_TYPE,10000,F)); + return result; +} + +#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ + REGISTER_ROOT(result##_g.array) + +void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); #define GROWABLE_ARRAY_ADD(result,elt) \ - result = tag_object(growable_array_add(untag_object(result),elt,&result##_count)) + growable_array_add(&result##_g,elt) -F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count); +void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); #define GROWABLE_ARRAY_APPEND(result,elts) \ - result = tag_object(growable_array_append(untag_object(result),elts,&result##_count)) + growable_array_append(&result##_g,elts) -#define GROWABLE_ARRAY_TRIM(result) \ - result = tag_object(reallot_array(untag_object(result),result##_count)) +INLINE CELL growable_array_trim(F_GROWABLE_ARRAY *array) +{ + return tag_object(reallot_array(untag_object(array->array),array->count)); +} + +#define GROWABLE_ARRAY_TRIM(result) CELL result = growable_array_trim(&result##_g) + +#define GROWABLE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array) /* Macros to simulate a byte vector in C */ -#define GROWABLE_BYTE_ARRAY(result) \ - CELL result##_count = 0; \ - CELL result = tag_object(allot_byte_array(100)) +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_BYTE_ARRAY; -F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count); +INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) +{ + F_GROWABLE_BYTE_ARRAY result; + result.count = 0; + result.array = tag_object(allot_byte_array(10000)); + return result; +} + +#define GROWABLE_BYTE_ARRAY(result) \ + F_GROWABLE_BYTE_ARRAY result##_g = make_growable_byte_array(); \ + REGISTER_ROOT(result##_g.array) + +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); #define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \ - result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count)) + growable_byte_array_append(&result##_g,elts,len) -#define GROWABLE_BYTE_ARRAY_TRIM(result) \ - result = tag_object(reallot_byte_array(untag_object(result),result##_count)) +INLINE CELL growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) +{ + return tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); +} + +#define GROWABLE_BYTE_ARRAY_TRIM(result) CELL result = growable_byte_array_trim(&result##_g) + +#define GROWABLE_BYTE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array); From a14e5a4a3b21ad8fdf37b8ade497db1da78acaa9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 08:06:37 -0500 Subject: [PATCH 20/83] Better local cache --- core/bootstrap/layouts/layouts.factor | 14 ++-- core/classes/builtin/builtin.factor | 4 +- core/generic/single/single.factor | 10 ++- vm/code_block.c | 2 +- vm/cpu-ppc.S | 2 +- vm/cpu-x86.32.S | 2 +- vm/cpu-x86.64.S | 2 +- vm/dispatch.c | 109 +++++++++++++------------- vm/layouts.h | 15 ++-- vm/run.h | 4 +- 10 files changed, 85 insertions(+), 79 deletions(-) diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 26100277a8..264756ab9b 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -14,13 +14,13 @@ BIN: 111 tag-mask set H{ { fixnum BIN: 000 } { bignum BIN: 001 } - { tuple BIN: 010 } - { object BIN: 011 } - { hi-tag BIN: 011 } - { ratio BIN: 100 } - { float BIN: 101 } - { complex BIN: 110 } - { POSTPONE: f BIN: 111 } + { ratio BIN: 010 } + { float BIN: 011 } + { complex BIN: 100 } + { POSTPONE: f BIN: 101 } + { object BIN: 110 } + { hi-tag BIN: 110 } + { tuple BIN: 111 } } tag-numbers set tag-numbers get H{ diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index f95d66fd05..32f7af8113 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -33,13 +33,13 @@ M: lo-tag-class define-builtin-predicate M: hi-tag-class define-builtin-predicate dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation - [ dup tag 3 eq? ] [ [ drop f ] if ] surround + [ dup tag 6 eq? ] [ [ drop f ] if ] surround define-predicate ; M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; M: hi-tag-class instance? - over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; + over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; M: builtin-class (flatten-class) dup set ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8d07132c8b..636f55632d 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -143,15 +143,19 @@ GENERIC: compile-engine ( engine -- obj ) : direct-dispatch-table ( assoc n -- table ) default get [ swap update ] keep ; +: lo-tag-number ( class -- n ) + "type" word-prop dup num-tags get member? + [ drop object tag-number ] unless ; + M: tag-dispatch-engine compile-engine methods>> compile-engines* - [ [ global [ target-word ] bind tag-number ] dip ] assoc-map + [ [ lo-tag-number ] dip ] assoc-map num-tags get direct-dispatch-table ; -: hi-tag-number ( class -- n ) "type" word-prop ; - : num-hi-tags ( -- n ) num-types get num-tags get - ; +: hi-tag-number ( class -- n ) "type" word-prop ; + M: hi-tag-dispatch-engine compile-engine methods>> compile-engines* [ [ hi-tag-number num-tags get - ] dip ] assoc-map diff --git a/vm/code_block.c b/vm/code_block.c index 8dda8bc16e..2fbea96378 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -220,7 +220,7 @@ void mark_object_code_block(CELL scan) F_QUOTATION *quot; F_CALLSTACK *stack; - switch(object_type(scan)) + switch(hi_tag(scan)) { case WORD_TYPE: word = (F_WORD *)scan; diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 8b3141218b..5e77c004aa 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,17(r3) /* load quotation-xt slot */ XX \ + lwz r11,14(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 7a8e579c62..22228eb6d9 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -29,7 +29,7 @@ and the callstack top is passed in EDX */ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 17 +#define QUOT_XT_OFFSET 14 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 8cf8fb9ae7..ba1f5b5409 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 37 +#define QUOT_XT_OFFSET 34 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/dispatch.c b/vm/dispatch.c index 3d6502d7b0..f5febaf707 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -38,24 +38,11 @@ static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) return ptr[echelon * 2 + 1]; } -INLINE CELL method_cache_hashcode(F_TUPLE_LAYOUT *layout, F_ARRAY *array) +static CELL lookup_tuple_method(CELL object, CELL methods) { - CELL capacity = (array_capacity(array) >> 1) - 1; - return (((CELL)layout >> TAG_BITS) & capacity) << 1; -} + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); -INLINE CELL lookup_tuple_method_fast(F_TUPLE_LAYOUT *layout, CELL method_cache) -{ - F_ARRAY *array = untag_object(method_cache); - CELL hashcode = method_cache_hashcode(layout,array); - if(array_nth(array,hashcode) == tag_object(layout)) - return array_nth(array,hashcode + 1); - else - return F; -} - -static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods) -{ F_ARRAY *echelons = untag_object(methods); F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); @@ -84,56 +71,68 @@ static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods) return F; } -static void update_method_cache(F_TUPLE_LAYOUT *layout, CELL method_cache, CELL method) -{ - F_ARRAY *array = untag_object(method_cache); - CELL hashcode = method_cache_hashcode(layout,array); - set_array_nth(array,hashcode,tag_object(layout)); - set_array_nth(array,hashcode + 1,method); -} - -static CELL lookup_tuple_method(CELL object, CELL methods, CELL method_cache) -{ - F_TUPLE *tuple = untag_object(object); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - - CELL method = lookup_tuple_method_fast(layout,method_cache); - if(method == F) - { - local_cache_misses++; - method = lookup_tuple_method_slow(layout,methods); - update_method_cache(layout,method_cache,method); - } - - return method; -} - static CELL lookup_hi_tag_method(CELL object, CELL methods) { F_ARRAY *hi_tag_methods = untag_object(methods); - CELL hi_tag = object_type(object); - return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); + return array_nth(hi_tag_methods,hi_tag(object) - HEADER_TYPE); +} + +static CELL method_cache_hashcode(CELL key, F_ARRAY *array) +{ + CELL capacity = (array_capacity(array) >> 1) - 1; + return ((key >> TAG_BITS) & capacity) << 1; +} + +static CELL lookup_cached_method(CELL key, CELL method_cache) +{ + F_ARRAY *array = untag_object(method_cache); + CELL hashcode = method_cache_hashcode(key,array); + if(array_nth(array,hashcode) == key) + return array_nth(array,hashcode + 1); + else + return F; +} + +static void update_method_cache(CELL key, CELL method_cache, CELL method) +{ + F_ARRAY *array = untag_object(method_cache); + CELL hashcode = method_cache_hashcode(key,array); + set_array_nth(array,hashcode,key); + set_array_nth(array,hashcode + 1,method); } static CELL lookup_method(CELL object, CELL methods, CELL method_cache) { F_ARRAY *tag_methods = untag_object(methods); - CELL tag = TAG(object); - CELL element = array_nth(tag_methods,tag); - - if(type_of(element) == WORD_TYPE) - return element; + if(!HI_TAG_OR_TUPLE_P(object)) + return array_nth(tag_methods,TAG(object)); else { - switch(tag) + CELL key = get(HI_TAG_HEADER(object)); + CELL method = lookup_cached_method(key,method_cache); + if(method != F) + return method; + else { - case TUPLE_TYPE: - return lookup_tuple_method(object,element,method_cache); - case OBJECT_TYPE: - return lookup_hi_tag_method(object,element); - default: - critical_error("Bad methods array",methods); - return F; + method = array_nth(tag_methods,TAG(object)); + if(type_of(method) != WORD_TYPE) + { + switch(TAG(object)) + { + case TUPLE_TYPE: + method = lookup_tuple_method(object,method); + break; + case OBJECT_TYPE: + method = lookup_hi_tag_method(object,method); + break; + default: + critical_error("Bad methods array",methods); + break; + } + } + + update_method_cache(key,method_cache,method); + return method; } } } diff --git a/vm/layouts.h b/vm/layouts.h index 9d92d2c386..266d790f2a 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -32,14 +32,17 @@ typedef signed long long s64; /*** Tags ***/ #define FIXNUM_TYPE 0 #define BIGNUM_TYPE 1 -#define TUPLE_TYPE 2 -#define OBJECT_TYPE 3 -#define RATIO_TYPE 4 -#define FLOAT_TYPE 5 -#define COMPLEX_TYPE 6 +#define RATIO_TYPE 2 +#define FLOAT_TYPE 3 +#define COMPLEX_TYPE 4 +#define F_TYPE 5 +#define OBJECT_TYPE 6 +#define TUPLE_TYPE 7 + +#define HI_TAG_OR_TUPLE_P(cell) (((CELL)(cell) & 6) == 6) +#define HI_TAG_HEADER(cell) (((CELL)(cell) & 1) * CELLS + UNTAG(cell)) /* Canonical F object */ -#define F_TYPE 7 #define F F_TYPE #define HEADER_TYPE 8 /* anything less than this is a tag */ diff --git a/vm/run.h b/vm/run.h index 3d9775ab6d..fb6e437404 100755 --- a/vm/run.h +++ b/vm/run.h @@ -139,7 +139,7 @@ INLINE CELL tag_object(void* cell) return RETAG(cell,OBJECT_TYPE); } -INLINE CELL object_type(CELL tagged) +INLINE CELL hi_tag(CELL tagged) { return untag_header(get(UNTAG(tagged))); } @@ -148,7 +148,7 @@ INLINE CELL type_of(CELL tagged) { CELL tag = TAG(tagged); if(tag == OBJECT_TYPE) - return object_type(tagged); + return hi_tag(tagged); else return tag; } From 5ff2c2e2bf7ff86148db26ea4dbba20b3ef5aba3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Apr 2009 14:10:12 -0500 Subject: [PATCH 21/83] Don't compile predicate engines since there's no gain --- basis/compiler/compiler.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d86c9234d1..e8a38b147e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -106,7 +106,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; ] if ; : optimize? ( word -- ? ) - { [ contains-breakpoints? ] [ single-generic? ] } 1|| not ; + { + [ predicate-engine-word? ] + [ contains-breakpoints? ] + [ single-generic? ] + } 1|| not ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since From 15ef4f651b0f0d78e6310e9cd42865f467c7ab98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 00:11:09 -0500 Subject: [PATCH 22/83] Sprinkle VM source with assertions, add a missing local root to quotations.c, fix GROWABLE_ARRAY macros for GC safety --- Makefile | 2 +- vm/bignumint.h | 2 +- vm/code_block.c | 25 ++++++++++++++++++++++ vm/code_heap.c | 4 ++-- vm/data_gc.c | 56 +++++++++++++++++++++++++++++++++++++++---------- vm/data_gc.h | 2 +- vm/factor.c | 3 +++ vm/master.h | 6 +++++- vm/profiler.c | 3 ++- vm/quotations.c | 15 +++++++++---- vm/run.h | 8 +++++++ vm/types.c | 2 +- vm/types.h | 47 ++++++++++++++++++++++++++++------------- 13 files changed, 137 insertions(+), 38 deletions(-) diff --git a/Makefile b/Makefile index a346bdfa0a..753c89c3d7 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CFLAGS = -Wall FFI_TEST_CFLAGS = -fPIC ifdef DEBUG - CFLAGS += -g + CFLAGS += -g -DFACTOR_DEBUG else CFLAGS += -O3 endif diff --git a/vm/bignumint.h b/vm/bignumint.h index a101473fc6..7c835686c2 100644 --- a/vm/bignumint.h +++ b/vm/bignumint.h @@ -64,7 +64,7 @@ typedef F_FIXNUM bignum_length_type; #define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1) -#define BIGNUM_NEGATIVE_P(bignum) (array_nth(bignum,0) != 0) +#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) #define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) #define BIGNUM_ZERO_P(bignum) \ diff --git a/vm/code_block.c b/vm/code_block.c index 100670bbe8..e7d8bec0ac 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -184,6 +184,13 @@ void update_word_references(F_CODE_BLOCK *compiled) } } +INLINE void check_code_address(CELL address) +{ +#ifdef FACTOR_DEBUG + assert(address >= code_heap.segment->start && address < code_heap.segment->end); +#endif +} + /* Update references to words. This is done after a new code block is added to the heap. */ @@ -191,6 +198,8 @@ is added to the heap. */ collections */ void mark_code_block(F_CODE_BLOCK *compiled) { + check_code_address((CELL)compiled); + mark_block(&compiled->block); copy_handle(&compiled->literals); @@ -287,6 +296,11 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) /* Compute an address to store at a relocation */ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) { +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,compiled->literals); + type_check(BYTE_ARRAY_TYPE,compiled->relocation); +#endif + CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); F_ARRAY *literals = untag_object(compiled->literals); F_FIXNUM absolute_value; @@ -410,6 +424,12 @@ F_CODE_BLOCK *add_code_block( CELL relocation, CELL literals) { +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,literals); + type_check(BYTE_ARRAY_TYPE,relocation); + assert(hi_tag(code) == ARRAY_TYPE); +#endif + CELL code_format = compiled_code_format(); CELL code_length = align8(array_capacity(code) * code_format); @@ -436,6 +456,11 @@ F_CODE_BLOCK *add_code_block( compiled->literals = literals; compiled->relocation = relocation; +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,compiled->literals); + type_check(BYTE_ARRAY_TYPE,compiled->relocation); +#endif + /* code */ deposit_integers((CELL)(compiled + 1),code,code_format); diff --git a/vm/code_heap.c b/vm/code_heap.c index 1901c592e6..0c63abfbe0 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -97,7 +97,7 @@ void primitive_modify_code_heap(void) { F_ARRAY *compiled_code = untag_array(data); - F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); + CELL literals = array_nth(compiled_code,0); CELL relocation = array_nth(compiled_code,1); F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); F_ARRAY *code = untag_array(array_nth(compiled_code,3)); @@ -110,7 +110,7 @@ void primitive_modify_code_heap(void) code, labels, relocation, - tag_object(literals)); + literals); UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); diff --git a/vm/data_gc.c b/vm/data_gc.c index 872358d362..458f01aaee 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,5 +1,16 @@ #include "master.h" +INLINE void check_data_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + if(!growing_data_heap) + { + assert(pointer >= data_heap->segment->start + && pointer < data_heap->segment->end); + } +#endif +} + /* Scan all the objects in the card */ void copy_card(F_CARD *ptr, CELL gen, CELL here) { @@ -211,6 +222,8 @@ INLINE CELL copy_object_impl(CELL pointer) /* Follow a chain of forwarding pointers */ CELL resolve_forwarding(CELL untagged, CELL tag) { + check_data_pointer(untagged); + CELL header = get(untagged); /* another forwarding pointer */ if(TAG(header) == GC_COLLECTED) @@ -218,6 +231,7 @@ CELL resolve_forwarding(CELL untagged, CELL tag) /* we've found the destination */ else { + check_header(header); CELL pointer = RETAG(untagged,tag); if(should_copy(untagged)) pointer = RETAG(copy_object_impl(pointer),tag); @@ -231,21 +245,30 @@ pointer address without copying anything; otherwise, install a new forwarding pointer. */ INLINE CELL copy_object(CELL pointer) { + check_data_pointer(pointer); + CELL tag = TAG(pointer); CELL header = get(UNTAG(pointer)); if(TAG(header) == GC_COLLECTED) return resolve_forwarding(UNTAG(header),tag); else + { + check_header(header); return RETAG(copy_object_impl(pointer),tag); + } } void copy_handle(CELL *handle) { CELL pointer = *handle; - if(!immediate_p(pointer) && should_copy(pointer)) - *handle = copy_object(pointer); + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(should_copy(pointer)) + *handle = copy_object(pointer); + } } CELL copy_next_from_nursery(CELL scan) @@ -264,9 +287,12 @@ CELL copy_next_from_nursery(CELL scan) { CELL pointer = *obj; - if(!immediate_p(pointer) - && (pointer >= nursery_start && pointer < nursery_end)) - *obj = copy_object(pointer); + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(pointer >= nursery_start && pointer < nursery_end) + *obj = copy_object(pointer); + } } } @@ -292,10 +318,13 @@ CELL copy_next_from_aging(CELL scan) { CELL pointer = *obj; - if(!immediate_p(pointer) - && !(pointer >= newspace_start && pointer < newspace_end) - && !(pointer >= tenured_start && pointer < tenured_end)) - *obj = copy_object(pointer); + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(!(pointer >= newspace_start && pointer < newspace_end) + && !(pointer >= tenured_start && pointer < tenured_end)) + *obj = copy_object(pointer); + } } } @@ -318,8 +347,12 @@ CELL copy_next_from_tenured(CELL scan) { CELL pointer = *obj; - if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end)) - *obj = copy_object(pointer); + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(!(pointer >= newspace_start && pointer < newspace_end)) + *obj = copy_object(pointer); + } } } @@ -474,6 +507,7 @@ void garbage_collection(CELL gen, copy_roots(); /* collect objects referenced from older generations */ copy_cards(); + /* do some tracing */ copy_reachable_objects(scan,&newspace->here); diff --git a/vm/data_gc.h b/vm/data_gc.h index a1184d53d4..31d7eddebb 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -93,7 +93,7 @@ INLINE void *allot_object(CELL type, CELL a) #ifdef GC_DEBUG if(!gc_off) { - if(gc_count++ % 1000 == 0) + if(gc_count++ % 100 == 0) gc(); } diff --git a/vm/factor.c b/vm/factor.c index 9b5d3de602..27ec80a4eb 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -118,7 +118,10 @@ void init_factor(F_PARAMETERS *p) init_stacks(p->ds_size,p->rs_size); load_image(p); init_c_io(); + +#ifndef FACTOR_DEBUG init_signals(); +#endif if(p->console) open_console(); diff --git a/vm/master.h b/vm/master.h index e2cafd9a87..c5375186bc 100644 --- a/vm/master.h +++ b/vm/master.h @@ -2,7 +2,11 @@ #define __FACTOR_MASTER_H__ #ifndef WINCE - #include +#include +#endif + +#ifdef FACTOR_DEBUG +#include #endif #include diff --git a/vm/profiler.c b/vm/profiler.c index acafecdff5..1fe5b110f7 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -48,7 +48,8 @@ void update_word_xt(F_WORD *word) word->xt = (XT)(word->code + 1); } -void set_profiling(bool profiling) +/* Allocates memory */ +static void set_profiling(bool profiling) { if(profiling == profiling_p) return; diff --git a/vm/quotations.c b/vm/quotations.c index 48979256ff..a6da41d458 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -204,6 +204,8 @@ void jit_compile(CELL quot, bool relocate) for(i = 0; i < length; i++) { CELL obj = array_nth(untag_object(array),i); + REGISTER_ROOT(obj); + F_WORD *word; F_WRAPPER *wrapper; @@ -325,6 +327,8 @@ void jit_compile(CELL quot, bool relocate) EMIT(userenv[JIT_PUSH_IMMEDIATE]) break; } + + UNREGISTER_ROOT(obj); } if(!tail_call) @@ -339,6 +343,10 @@ void jit_compile(CELL quot, bool relocate) GROWABLE_BYTE_ARRAY_TRIM(relocation); GROWABLE_ARRAY_TRIM(code); + GROWABLE_ARRAY_DONE(literals); + GROWABLE_BYTE_ARRAY_DONE(relocation); + GROWABLE_ARRAY_DONE(code); + F_CODE_BLOCK *compiled = add_code_block( QUOTATION_TYPE, untag_object(code), @@ -351,10 +359,6 @@ void jit_compile(CELL quot, bool relocate) if(relocate) relocate_code_block(compiled); - GROWABLE_ARRAY_DONE(literals); - GROWABLE_BYTE_ARRAY_DONE(relocation); - GROWABLE_ARRAY_DONE(code); - UNREGISTER_ROOT(array); UNREGISTER_ROOT(quot); } @@ -536,10 +540,13 @@ void compile_all_words(void) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); + if(word->optimizedp == F) jit_compile_word(word,word->def,false); + UNREGISTER_UNTAGGED(word); update_word_xt(word); + } UNREGISTER_ROOT(words); diff --git a/vm/run.h b/vm/run.h index fb6e437404..ba183fb6d4 100755 --- a/vm/run.h +++ b/vm/run.h @@ -129,8 +129,16 @@ INLINE CELL tag_header(CELL cell) return cell << TAG_BITS; } +INLINE void check_header(CELL cell) +{ +#ifdef FACTOR_DEBUG + assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT); +#endif +} + INLINE CELL untag_header(CELL cell) { + check_header(cell); return cell >> TAG_BITS; } diff --git a/vm/types.c b/vm/types.c index 1985f51567..644c205460 100755 --- a/vm/types.c +++ b/vm/types.c @@ -224,7 +224,7 @@ void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) UNREGISTER_UNTAGGED(elts); - write_barrier((CELL)array->array); + write_barrier(array->array); memcpy((void *)AREF(underlying,array->count), (void *)AREF(elts,0), diff --git a/vm/types.h b/vm/types.h index 01176d6191..f3039f945c 100755 --- a/vm/types.h +++ b/vm/types.h @@ -40,25 +40,37 @@ INLINE CELL tag_boolean(CELL untagged) DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) +INLINE CELL array_capacity(F_ARRAY* array) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE); +#endif + return array->capacity >> TAG_BITS; +} + #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) INLINE CELL array_nth(F_ARRAY *array, CELL slot) { +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == ARRAY_TYPE); +#endif return get(AREF(array,slot)); } INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value) { +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == ARRAY_TYPE); +#endif put(AREF(array,slot),value); write_barrier((CELL)array); } -INLINE CELL array_capacity(F_ARRAY* array) -{ - return array->capacity >> TAG_BITS; -} - #define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) #define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) @@ -164,11 +176,12 @@ typedef struct { CELL array; } F_GROWABLE_ARRAY; +/* Allocates memory */ INLINE F_GROWABLE_ARRAY make_growable_array(void) { F_GROWABLE_ARRAY result; result.count = 0; - result.array = tag_object(allot_array(ARRAY_TYPE,10000,F)); + result.array = tag_object(allot_array(ARRAY_TYPE,100,F)); return result; } @@ -185,14 +198,16 @@ void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); #define GROWABLE_ARRAY_APPEND(result,elts) \ growable_array_append(&result##_g,elts) -INLINE CELL growable_array_trim(F_GROWABLE_ARRAY *array) +INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) { - return tag_object(reallot_array(untag_object(array->array),array->count)); + array->array = tag_object(reallot_array(untag_object(array->array),array->count)); } -#define GROWABLE_ARRAY_TRIM(result) CELL result = growable_array_trim(&result##_g) +#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) -#define GROWABLE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array) +#define GROWABLE_ARRAY_DONE(result) \ + UNREGISTER_ROOT(result##_g.array); \ + CELL result = result##_g.array; /* Macros to simulate a byte vector in C */ typedef struct { @@ -204,7 +219,7 @@ INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) { F_GROWABLE_BYTE_ARRAY result; result.count = 0; - result.array = tag_object(allot_byte_array(10000)); + result.array = tag_object(allot_byte_array(100)); return result; } @@ -217,11 +232,13 @@ void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL #define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \ growable_byte_array_append(&result##_g,elts,len) -INLINE CELL growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) +INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) { - return tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); + byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); } -#define GROWABLE_BYTE_ARRAY_TRIM(result) CELL result = growable_byte_array_trim(&result##_g) +#define GROWABLE_BYTE_ARRAY_TRIM(result) growable_byte_array_trim(&result##_g) -#define GROWABLE_BYTE_ARRAY_DONE(result) UNREGISTER_ROOT(result##_g.array); +#define GROWABLE_BYTE_ARRAY_DONE(result) \ + UNREGISTER_ROOT(result##_g.array); \ + CELL result = result##_g.array; From e45790a802dde54d1566a80eddb32c4fa0e3ba82 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 00:48:00 -0500 Subject: [PATCH 23/83] Split off parts of quotations.c into jit.c, which is a general codegen facility used by the non-optimizing compiler, and soon to be the profiler and PICs --- Makefile | 1 + vm/data_gc.c | 11 ---- vm/data_gc.h | 11 ++++ vm/data_heap.h | 1 + vm/jit.c | 79 +++++++++++++++++++++++ vm/jit.h | 46 +++++++++++++ vm/local_roots.h | 7 +- vm/master.h | 3 +- vm/quotations.c | 163 +++++++++++++---------------------------------- vm/types.c | 8 +++ 10 files changed, 199 insertions(+), 131 deletions(-) create mode 100644 vm/jit.c create mode 100644 vm/jit.h diff --git a/Makefile b/Makefile index 753c89c3d7..dfc0f71ff6 100644 --- a/Makefile +++ b/Makefile @@ -41,6 +41,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/factor.o \ vm/image.o \ vm/io.o \ + vm/jit.o \ vm/math.o \ vm/primitives.o \ vm/profiler.o \ diff --git a/vm/data_gc.c b/vm/data_gc.c index 458f01aaee..91bb9ab857 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,16 +1,5 @@ #include "master.h" -INLINE void check_data_pointer(CELL pointer) -{ -#ifdef FACTOR_DEBUG - if(!growing_data_heap) - { - assert(pointer >= data_heap->segment->start - && pointer < data_heap->segment->end); - } -#endif -} - /* Scan all the objects in the card */ void copy_card(F_CARD *ptr, CELL gen, CELL here) { diff --git a/vm/data_gc.h b/vm/data_gc.h index 31d7eddebb..50f87ce0be 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -153,3 +153,14 @@ void primitive_gc_stats(void); void clear_gc_stats(void); void primitive_clear_gc_stats(void); void primitive_become(void); + +INLINE void check_data_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + if(!growing_data_heap) + { + assert(pointer >= data_heap->segment->start + && pointer < data_heap->segment->end); + } +#endif +} diff --git a/vm/data_heap.h b/vm/data_heap.h index 5836967295..4a86367208 100644 --- a/vm/data_heap.h +++ b/vm/data_heap.h @@ -135,3 +135,4 @@ INLINE void do_slots(CELL obj, void (* iter)(CELL *)) scan += CELLS; } } + diff --git a/vm/jit.c b/vm/jit.c new file mode 100644 index 0000000000..184cccf39f --- /dev/null +++ b/vm/jit.c @@ -0,0 +1,79 @@ +#include "master.h" + +/* Allocates memory */ +void jit_init(F_JIT *jit, CELL jit_type, CELL owner) +{ + jit->owner = owner; + REGISTER_ROOT(jit->owner); + + jit->type = jit_type; + jit->code_format = compiled_code_format(); + + jit->code = make_growable_array(); + REGISTER_ROOT(jit->code.array); + jit->relocation = make_growable_byte_array(); + REGISTER_ROOT(jit->relocation.array); + jit->literals = make_growable_array(); + REGISTER_ROOT(jit->literals.array); + + if(stack_traces_p()) + growable_array_add(&jit->literals,jit->owner); +} + +/* Allocates memory */ +F_CODE_BLOCK *jit_make_code_block(F_JIT *jit) +{ + growable_array_trim(&jit->code); + growable_byte_array_trim(&jit->relocation); + growable_array_trim(&jit->literals); + + F_CODE_BLOCK *code = add_code_block( + jit->type, + untag_object(jit->code.array), + NULL, /* no labels */ + jit->relocation.array, + jit->literals.array); + + return code; +} + +void jit_dispose(F_JIT *jit) +{ + UNREGISTER_ROOT(jit->literals.array); + UNREGISTER_ROOT(jit->relocation.array); + UNREGISTER_ROOT(jit->code.array); + UNREGISTER_ROOT(jit->owner); +} + +static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p) +{ + F_ARRAY *quadruple = untag_object(template); + CELL rel_class = array_nth(quadruple,1); + CELL rel_type = array_nth(quadruple,2); + CELL offset = array_nth(quadruple,3); + + if(rel_class == F) + { + *rel_p = false; + return 0; + } + else + { + *rel_p = true; + return (to_fixnum(rel_type) << 28) + | (to_fixnum(rel_class) << 24) + | ((jit->code.count + to_fixnum(offset)) * jit->code_format); + } +} + +/* Allocates memory */ +void jit_emit(F_JIT *jit, CELL template) +{ + REGISTER_ROOT(template); + bool rel_p; + F_REL rel = rel_to_emit(jit,template,&rel_p); + if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); + growable_array_append(&jit->code,code_to_emit(template)); + UNREGISTER_ROOT(template); +} + diff --git a/vm/jit.h b/vm/jit.h new file mode 100644 index 0000000000..deafb48308 --- /dev/null +++ b/vm/jit.h @@ -0,0 +1,46 @@ +typedef struct { + CELL type; + CELL owner; + CELL code_format; + F_GROWABLE_ARRAY code; + F_GROWABLE_BYTE_ARRAY relocation; + F_GROWABLE_ARRAY literals; +} F_JIT; + +void jit_init(F_JIT *jit, CELL jit_type, CELL owner); +F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); +void jit_dispose(F_JIT *jit); + +INLINE F_ARRAY *code_to_emit(CELL template) +{ + return untag_object(array_nth(untag_object(template),0)); +} + +void jit_emit(F_JIT *jit, CELL template); + +/* Allocates memory */ +INLINE void jit_add_literal(F_JIT *jit, CELL literal) +{ + growable_array_add(&jit->literals,literal); +} + +/* Allocates memory */ +INLINE void jit_emit_with(F_JIT *jit, CELL template, CELL argument) +{ + REGISTER_ROOT(template); + jit_add_literal(jit,argument); + UNREGISTER_ROOT(template); + jit_emit(jit,template); +} + +/* Allocates memory */ +INLINE void jit_push(F_JIT *jit, CELL literal) +{ + jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal); +} + +/* Allocates memory */ +INLINE void jit_word_jump(F_JIT *jit, CELL word) +{ + jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); +} diff --git a/vm/local_roots.h b/vm/local_roots.h index 6d9658dbd3..59f1bfc4e6 100644 --- a/vm/local_roots.h +++ b/vm/local_roots.h @@ -19,7 +19,12 @@ CELL gc_locals; DEFPUSHPOP(gc_local_,gc_locals) -#define REGISTER_ROOT(obj) gc_local_push((CELL)&(obj)) +#define REGISTER_ROOT(obj) \ + { \ + if(!immediate_p(obj)) \ + check_data_pointer(obj); \ + gc_local_push((CELL)&(obj)); \ + } #define UNREGISTER_ROOT(obj) \ { \ if(gc_local_pop() != (CELL)&(obj)) \ diff --git a/vm/master.h b/vm/master.h index c5375186bc..c89d6d2092 100644 --- a/vm/master.h +++ b/vm/master.h @@ -31,8 +31,8 @@ #include "bignum.h" #include "write_barrier.h" #include "data_heap.h" -#include "local_roots.h" #include "data_gc.h" +#include "local_roots.h" #include "debug.h" #include "types.h" #include "math.h" @@ -46,6 +46,7 @@ #include "alien.h" #include "quotations.h" #include "dispatch.h" +#include "jit.h" #include "factor.h" #include "utilities.h" diff --git a/vm/quotations.c b/vm/quotations.c index a6da41d458..d149dab6c9 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -39,14 +39,14 @@ includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) so this results in a big speedup for relatively little effort. */ -bool jit_primitive_call_p(F_ARRAY *array, CELL i) +static bool jit_primitive_call_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) && type_of(array_nth(array,i)) == FIXNUM_TYPE && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD]; } -bool jit_fast_if_p(F_ARRAY *array, CELL i) +static bool jit_fast_if_p(F_ARRAY *array, CELL i) { return (i + 3) == array_capacity(array) && type_of(array_nth(array,i)) == QUOTATION_TYPE @@ -54,42 +54,42 @@ bool jit_fast_if_p(F_ARRAY *array, CELL i) && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; } -bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) +static bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) && type_of(array_nth(array,i)) == ARRAY_TYPE && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } -bool jit_fast_dip_p(F_ARRAY *array, CELL i) +static bool jit_fast_dip_p(F_ARRAY *array, CELL i) { return (i + 2) <= array_capacity(array) && type_of(array_nth(array,i)) == QUOTATION_TYPE && array_nth(array,i + 1) == userenv[JIT_DIP_WORD]; } -bool jit_fast_2dip_p(F_ARRAY *array, CELL i) +static bool jit_fast_2dip_p(F_ARRAY *array, CELL i) { return (i + 2) <= array_capacity(array) && type_of(array_nth(array,i)) == QUOTATION_TYPE && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD]; } -bool jit_fast_3dip_p(F_ARRAY *array, CELL i) +static bool jit_fast_3dip_p(F_ARRAY *array, CELL i) { return (i + 2) <= array_capacity(array) && type_of(array_nth(array,i)) == QUOTATION_TYPE && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; } -bool jit_ignore_declare_p(F_ARRAY *array, CELL i) +static bool jit_ignore_declare_p(F_ARRAY *array, CELL i) { return (i + 1) < array_capacity(array) && type_of(array_nth(array,i)) == ARRAY_TYPE && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; } -bool jit_stack_frame_p(F_ARRAY *array) +static bool jit_stack_frame_p(F_ARRAY *array) { F_FIXNUM length = array_capacity(array); F_FIXNUM i; @@ -125,51 +125,9 @@ void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) quot->compiledp = T; } -F_ARRAY *code_to_emit(CELL template) -{ - return untag_object(array_nth(untag_object(template),0)); -} - -F_REL rel_to_emit(CELL template, CELL code_format, CELL code_length, bool *rel_p) -{ - F_ARRAY *quadruple = untag_object(template); - CELL rel_class = array_nth(quadruple,1); - CELL rel_type = array_nth(quadruple,2); - CELL offset = array_nth(quadruple,3); - - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (to_fixnum(rel_type) << 28) - | (to_fixnum(rel_class) << 24) - | ((code_length + to_fixnum(offset)) * code_format); - } -} - -static void jit_emit(CELL template, CELL code_format, - F_GROWABLE_ARRAY *code, F_GROWABLE_BYTE_ARRAY *relocation) -{ - REGISTER_ROOT(template); - bool rel_p; - F_REL rel = rel_to_emit(template,code_format,code->count,&rel_p); - if(rel_p) growable_byte_array_append(relocation,&rel,sizeof(F_REL)); - growable_array_append(code,code_to_emit(template)); - UNREGISTER_ROOT(template); -} - -#define EMIT(template) { jit_emit(template,code_format,&code_g,&relocation_g); } - -#define EMIT_LITERAL GROWABLE_ARRAY_ADD(literals,obj); - -#define EMIT_TAIL_CALL(template) { \ - if(stack_frame) EMIT(userenv[JIT_EPILOG]); \ - tail_call = true; \ - EMIT(template); \ +#define EMIT_TAIL_CALL { \ + if(stack_frame) jit_emit(&jit,userenv[JIT_EPILOG]); \ + tail_call = true; \ } /* Might GC */ @@ -178,24 +136,18 @@ void jit_compile(CELL quot, bool relocate) if(untag_quotation(quot)->compiledp != F) return; - CELL code_format = compiled_code_format(); - CELL array = untag_quotation(quot)->array; REGISTER_ROOT(quot); REGISTER_ROOT(array); - GROWABLE_ARRAY(code); - GROWABLE_BYTE_ARRAY(relocation); - GROWABLE_ARRAY(literals); - - if(stack_traces_p()) - GROWABLE_ARRAY_ADD(literals,quot); + F_JIT jit; + jit_init(&jit,QUOTATION_TYPE,quot); bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - EMIT(userenv[JIT_PROLOG]) + jit_emit(&jit,userenv[JIT_PROLOG]); CELL i; CELL length = array_capacity(untag_object(array)); @@ -219,39 +171,43 @@ void jit_compile(CELL quot, bool relocate) { REGISTER_UNTAGGED(word); if(array_nth(untag_object(word->subprimitive),1) != F) - GROWABLE_ARRAY_ADD(literals,T); + jit_add_literal(&jit,T); UNREGISTER_UNTAGGED(word); - EMIT(word->subprimitive) + jit_emit(&jit,word->subprimitive); } + /* The (execute) primitive is special-cased */ else if(obj == userenv[JIT_EXECUTE_WORD]) { if(i == length - 1) - EMIT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP]) + { + EMIT_TAIL_CALL; + jit_emit(&jit,userenv[JIT_EXECUTE_JUMP]); + } else - EMIT(userenv[JIT_EXECUTE_CALL]) + jit_emit(&jit,userenv[JIT_EXECUTE_CALL]); } + /* Everything else */ else { - EMIT_LITERAL - if(i == length - 1) - EMIT_TAIL_CALL(userenv[JIT_WORD_JUMP]) + { + EMIT_TAIL_CALL; + jit_word_jump(&jit,obj); + } else - EMIT(userenv[JIT_WORD_CALL]) + jit_emit_with(&jit,userenv[JIT_WORD_CALL],obj); } break; case WRAPPER_TYPE: wrapper = untag_object(obj); - GROWABLE_ARRAY_ADD(literals,wrapper->object); - EMIT(userenv[JIT_PUSH_IMMEDIATE]) + jit_push(&jit,wrapper->object); break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - EMIT(userenv[JIT_SAVE_STACK]) - EMIT_LITERAL - EMIT(userenv[JIT_PRIMITIVE]) + jit_emit(&jit,userenv[JIT_SAVE_STACK]); + jit_emit_with(&jit,userenv[JIT_PRIMITIVE],obj); i++; @@ -261,18 +217,13 @@ void jit_compile(CELL quot, bool relocate) case QUOTATION_TYPE: if(jit_fast_if_p(untag_object(array),i)) { - if(stack_frame) - EMIT(userenv[JIT_EPILOG]) - - tail_call = true; + EMIT_TAIL_CALL; jit_compile(array_nth(untag_object(array),i),relocate); jit_compile(array_nth(untag_object(array),i + 1),relocate); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(userenv[JIT_IF_1]) - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); - EMIT(userenv[JIT_IF_2]) + jit_emit_with(&jit,userenv[JIT_IF_1],array_nth(untag_object(array),i)); + jit_emit_with(&jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1)); i += 2; @@ -281,38 +232,29 @@ void jit_compile(CELL quot, bool relocate) else if(jit_fast_dip_p(untag_object(array),i)) { jit_compile(obj,relocate); - - EMIT_LITERAL - EMIT(userenv[JIT_DIP]) - + jit_emit_with(&jit,userenv[JIT_DIP],obj); i++; break; } else if(jit_fast_2dip_p(untag_object(array),i)) { jit_compile(obj,relocate); - - EMIT_LITERAL - EMIT(userenv[JIT_2DIP]) - + jit_emit_with(&jit,userenv[JIT_2DIP],obj); i++; break; } else if(jit_fast_3dip_p(untag_object(array),i)) { jit_compile(obj,relocate); - - EMIT_LITERAL - EMIT(userenv[JIT_3DIP]) - + jit_emit_with(&jit,userenv[JIT_3DIP],obj); i++; break; } case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { - EMIT_LITERAL - EMIT_TAIL_CALL(userenv[JIT_DISPATCH]) + EMIT_TAIL_CALL; + jit_emit_with(&jit,userenv[JIT_DISPATCH],obj); i++; break; @@ -323,8 +265,7 @@ void jit_compile(CELL quot, bool relocate) break; } default: - EMIT_LITERAL - EMIT(userenv[JIT_PUSH_IMMEDIATE]) + jit_push(&jit,obj); break; } @@ -334,31 +275,18 @@ void jit_compile(CELL quot, bool relocate) if(!tail_call) { if(stack_frame) - EMIT(userenv[JIT_EPILOG]) - - EMIT(userenv[JIT_RETURN]) + jit_emit(&jit,userenv[JIT_EPILOG]); + jit_emit(&jit,userenv[JIT_RETURN]); } - GROWABLE_ARRAY_TRIM(literals); - GROWABLE_BYTE_ARRAY_TRIM(relocation); - GROWABLE_ARRAY_TRIM(code); - - GROWABLE_ARRAY_DONE(literals); - GROWABLE_BYTE_ARRAY_DONE(relocation); - GROWABLE_ARRAY_DONE(code); - - F_CODE_BLOCK *compiled = add_code_block( - QUOTATION_TYPE, - untag_object(code), - NULL, - relocation, - literals); - + F_CODE_BLOCK *compiled = jit_make_code_block(&jit); set_quot_xt(untag_object(quot),compiled); if(relocate) relocate_code_block(compiled); + jit_dispose(&jit); + UNREGISTER_ROOT(array); UNREGISTER_ROOT(quot); } @@ -405,7 +333,6 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) switch(type_of(obj)) { case WORD_TYPE: - /* Intrinsics */ word = untag_object(obj); if(word->subprimitive != F) COUNT(word->subprimitive,i) diff --git a/vm/types.c b/vm/types.c index 644c205460..64f545dec5 100755 --- a/vm/types.c +++ b/vm/types.c @@ -171,6 +171,10 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) { +#ifdef FACTOR_DEBUG + assert(untag_header(array->header) == ARRAY_TYPE); +#endif + CELL to_copy = array_capacity(array); if(capacity < to_copy) to_copy = capacity; @@ -267,6 +271,10 @@ void primitive_uninitialized_byte_array(void) F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) { +#ifdef FACTOR_DEBUG + assert(untag_header(array->header) == BYTE_ARRAY_TYPE); +#endif + CELL to_copy = array_capacity(array); if(capacity < to_copy) to_copy = capacity; From d5b51df7e74061af3d557b51aeafd1c13e27eb80 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 00:53:32 -0500 Subject: [PATCH 24/83] Clean up profiler.c using new JIT API --- vm/profiler.c | 36 ++++++++++-------------------------- vm/profiler.h | 1 - 2 files changed, 10 insertions(+), 27 deletions(-) diff --git a/vm/profiler.c b/vm/profiler.c index 1fe5b110f7..7952a6b6f5 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -1,32 +1,16 @@ #include "master.h" /* Allocates memory */ -F_CODE_BLOCK *compile_profiling_stub(F_WORD *word) +static F_CODE_BLOCK *compile_profiling_stub(CELL word) { - CELL literals = allot_array_2(tag_object(word),tag_object(word)); - REGISTER_ROOT(literals); - - F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]); - - CELL code = array_nth(quadruple,0); - REGISTER_ROOT(code); - - F_REL rel = (to_fixnum(array_nth(quadruple,1)) << 24) - | (to_fixnum(array_nth(quadruple,2)) << 28) - | (to_fixnum(array_nth(quadruple,3)) * compiled_code_format()); - - F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL)); - memcpy(relocation + 1,&rel,sizeof(F_REL)); - - UNREGISTER_ROOT(code); - UNREGISTER_ROOT(literals); - - return add_code_block( - WORD_TYPE, - untag_object(code), - NULL, /* no labels */ - tag_object(relocation), - literals); + REGISTER_ROOT(word); + F_JIT jit; + jit_init(&jit,WORD_TYPE,word); + jit_emit_with(&jit,userenv[JIT_PROFILING],word); + F_CODE_BLOCK *block = jit_make_code_block(&jit); + jit_dispose(&jit); + UNREGISTER_ROOT(word); + return block; } /* Allocates memory */ @@ -37,7 +21,7 @@ void update_word_xt(F_WORD *word) if(!word->profiling) { REGISTER_UNTAGGED(word); - F_CODE_BLOCK *profiling = compile_profiling_stub(word); + F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); UNREGISTER_UNTAGGED(word); word->profiling = profiling; } diff --git a/vm/profiler.h b/vm/profiler.h index 4a44ec3f36..481f75e966 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,4 +1,3 @@ bool profiling_p; void primitive_profiling(void); -F_CODE_BLOCK *compile_profiling_stub(F_WORD *word); void update_word_xt(F_WORD *word); From 4d10105802c360fdc12a1f19596cf69abe347a7b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 03:48:37 -0500 Subject: [PATCH 25/83] Working on inline caching --- Makefile | 1 + basis/bootstrap/image/image.factor | 54 +++++-- basis/cpu/x86/assembler/assembler.factor | 13 +- basis/cpu/x86/bootstrap.factor | 56 ++++++- core/bootstrap/primitives.factor | 1 + vm/code_block.c | 2 +- vm/cpu-x86.S | 6 +- vm/cpu-x86.h | 15 ++ vm/dispatch.c | 65 +++++--- vm/inline_cache.c | 182 +++++++++++++++++++++++ vm/inline_cache.h | 8 + vm/jit.h | 11 ++ vm/master.h | 1 + vm/primitives.c | 3 +- vm/quotations.c | 9 +- vm/run.h | 11 +- vm/types.c | 3 +- 17 files changed, 385 insertions(+), 56 deletions(-) create mode 100644 vm/inline_cache.c create mode 100644 vm/inline_cache.h diff --git a/Makefile b/Makefile index dfc0f71ff6..d5c7e00763 100644 --- a/Makefile +++ b/Makefile @@ -40,6 +40,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/errors.o \ vm/factor.o \ vm/image.o \ + vm/inline_cache.o \ vm/io.o \ vm/jit.o \ vm/math.o \ diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 91aafa9f92..f2dd6e07fd 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -5,10 +5,10 @@ hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts splitting grouping growable classes -classes.builtin classes.tuple classes.tuple.private -vocabs vocabs.loader source-files definitions debugger -quotations.private sequences.private combinators math.order -math.private accessors slots.private compiler.units compiler.constants +classes.builtin classes.tuple classes.tuple.private vocabs +vocabs.loader source-files definitions debugger quotations.private +sequences.private combinators math.order math.private accessors +slots.private generic.single.private compiler.units compiler.constants fry ; IN: bootstrap.image @@ -162,6 +162,15 @@ SYMBOL: jit-profiling SYMBOL: jit-declare-word SYMBOL: jit-save-stack +! PIC stubs +SYMBOL: pic-tag +SYMBOL: pic-hi-tag +SYMBOL: pic-tuple +SYMBOL: pic-hi-tag-tuple +SYMBOL: pic-check +SYMBOL: pic-hit +SYMBOL: pic-miss-word + ! Default definition for undefined words SYMBOL: undefined-quot @@ -184,17 +193,24 @@ SYMBOL: undefined-quot { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-declare-word 42 } - { jit-save-stack 43 } - { jit-dip-word 44 } - { jit-dip 45 } - { jit-2dip-word 46 } - { jit-2dip 47 } - { jit-3dip-word 48 } - { jit-3dip 49 } - { jit-execute-word 50 } - { jit-execute-jump 51 } - { jit-execute-call 52 } + { jit-declare-word 37 } + { jit-save-stack 38 } + { jit-dip-word 39 } + { jit-dip 40 } + { jit-2dip-word 41 } + { jit-2dip 42 } + { jit-3dip-word 43 } + { jit-3dip 44 } + { jit-execute-word 45 } + { jit-execute-jump 46 } + { jit-execute-call 47 } + { pic-tag 48 } + { pic-hi-tag 49 } + { pic-tuple 50 } + { pic-hi-tag-tuple 51 } + { pic-check 52 } + { pic-hit 53 } + { pic-miss-word 54 } { undefined-quot 60 } } ; inline @@ -509,6 +525,7 @@ M: quotation ' \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set \ (execute) jit-execute-word set + \ inline-cache-miss \ pic-miss-word set [ undefined ] undefined-quot set { jit-code-format @@ -537,6 +554,13 @@ M: quotation ' jit-profiling jit-declare-word jit-save-stack + pic-tag + pic-hi-tag + pic-tuple + pic-hi-tag-tuple + pic-check + pic-hit + pic-miss-word undefined-quot } [ emit-userenv ] each ; diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 3a98d47416..9b34875bc1 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -321,10 +321,11 @@ M: label CALL (CALL) label-fixup ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; -M: f JUMPcc nip (JUMPcc) drop ; -M: callable JUMPcc (JUMPcc) rel-word ; -M: label JUMPcc (JUMPcc) label-fixup ; +: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; +M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; +M: integer JUMPcc (JUMPcc) drop ; +M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; +M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; @@ -382,6 +383,10 @@ GENERIC: CMP ( dst src -- ) M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: operand CMP OCT: 070 2-operand ; +GENERIC: TEST ( dst src -- ) +M: immediate TEST swap { BIN: 101 t HEX: 84 } immediate-1/4 ; +M: operand TEST OCT: 204 2-operand ; + : XCHG ( dst src -- ) OCT: 207 2-operand ; : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index dd17ef4186..77a34277ab 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler layouts compiler.units math math.private compiler.constants vocabs slots.private words -locals.backend ; +locals.backend make sequences combinators ; IN: bootstrap.x86 big-endian off @@ -170,7 +170,57 @@ big-endian off [ 0 RET ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! The 'make' trick lets us compute the jump distance for the conditional branches there + +! Tag +[ + ds-reg bootstrap-cell SUB + temp0 tag-bits get AND +] pic-tag jit-define + +! Hi-tag +[ + ds-reg bootstrap-cell SUB + temp0 object tag-number TEST + [ temp0 temp0 object tag-number neg [+] MOV ] { } make + [ length JNE ] [ % ] bi +] pic-hi-tag jit-define + +! Tuple +[ + ds-reg bootstrap-cell SUB + temp0 tuple tag-number TEST + [ temp0 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make + [ length JNE ] [ % ] bi +] pic-tuple jit-define + +! Hi-tag and tuple +[ + ds-reg bootstrap-cell SUB + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + temp0 6 TEST + [ + temp1 temp0 MOV + ! Make temp0 untagged + temp0 tag-mask get bitnot AND + ! Set temp1 to 0 for objects, and 4 or 8 for tuples + temp1 1 AND + bootstrap-cell { + { 4 [ temp1 2 SHL ] } + { 8 [ temp1 3 SHL ] } + } case + ! Load header cell or tuple layout cell + temp0 temp0 temp1 [+] MOV + ] [ ] make [ length JNE ] [ % ] bi +] pic-hi-tag-tuple jit-define + +[ temp0 HEX: ffffffff CMP ] pic-check jit-define + +[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define + +! ! ! Sub-primitives ! Quotations and words [ diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 62f23f206d..b618e64d41 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,6 +533,7 @@ tuple { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) } + { "inline-cache-miss" "generic.single.private" (( generic methods -- )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/vm/code_block.c b/vm/code_block.c index e7d8bec0ac..391c8cf56e 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -427,7 +427,7 @@ F_CODE_BLOCK *add_code_block( #ifdef FACTOR_DEBUG type_check(ARRAY_TYPE,literals); type_check(BYTE_ARRAY_TYPE,relocation); - assert(hi_tag(code) == ARRAY_TYPE); + assert(untag_header(code->header) == ARRAY_TYPE); #endif CELL code_format = compiled_code_format(); diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 7a0d738fe0..5dfc55cbd5 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -60,7 +60,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): mov ARG1,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) -DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): +DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ sub $STACK_PADDING,STACK_REG call MANGLE(lazy_jit_compile_impl) @@ -68,6 +68,10 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): add $STACK_PADDING,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ +DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): + mov (STACK_REG),ARG0 + jmp MANGLE(inline_cache_miss) + #ifdef WINDOWS .section .drectve .ascii " -export:c_to_factor" diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index 3b08479e4b..d84a480b08 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -1,3 +1,5 @@ +#include + #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) INLINE void flush_icache(CELL start, CELL len) {} @@ -7,3 +9,16 @@ F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); F_FASTCALL void lazy_jit_compile(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); + +INLINE void set_call_site(CELL return_address, CELL target) +{ + /* An x86 CALL instruction looks like so: + |e8|..|..|..|..| + where the ... are a PC-relative jump address. + The return_address points to right after the + instruction. */ +#ifdef FACTOR_DEBUG + assert(*(unsigned char *)(return_address - 5) == 0xe8); +#endif + *(F_FIXNUM *)(return_address - 4) = (target - (return_address - 4)); +} diff --git a/vm/dispatch.c b/vm/dispatch.c index f5febaf707..8093912080 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -101,11 +101,32 @@ static void update_method_cache(CELL key, CELL method_cache, CELL method) set_array_nth(array,hashcode + 1,method); } -static CELL lookup_method(CELL object, CELL methods, CELL method_cache) +static CELL lookup_hairy_method(CELL object, CELL methods) +{ + CELL method = array_nth(untag_object(methods),TAG(object)); + if(type_of(method) == WORD_TYPE) + return method; + else + { + switch(TAG(object)) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,method); + break; + case OBJECT_TYPE: + return lookup_hi_tag_method(object,method); + break; + default: + critical_error("Bad methods array",methods); + return -1; + } + } +} + +static CELL lookup_method_with_cache(CELL object, CELL methods, CELL method_cache) { - F_ARRAY *tag_methods = untag_object(methods); if(!HI_TAG_OR_TUPLE_P(object)) - return array_nth(tag_methods,TAG(object)); + return array_nth(untag_object(methods),TAG(object)); else { CELL key = get(HI_TAG_HEADER(object)); @@ -114,23 +135,7 @@ static CELL lookup_method(CELL object, CELL methods, CELL method_cache) return method; else { - method = array_nth(tag_methods,TAG(object)); - if(type_of(method) != WORD_TYPE) - { - switch(TAG(object)) - { - case TUPLE_TYPE: - method = lookup_tuple_method(object,method); - break; - case OBJECT_TYPE: - method = lookup_hi_tag_method(object,method); - break; - default: - critical_error("Bad methods array",methods); - break; - } - } - + method = lookup_hairy_method(object,methods); update_method_cache(key,method_cache,method); return method; } @@ -143,5 +148,23 @@ void primitive_lookup_method(void) CELL methods = get(ds - CELLS); CELL object = get(ds - CELLS * 2); ds -= CELLS * 2; - drepl(lookup_method(object,methods,method_cache)); + drepl(lookup_method_with_cache(object,methods,method_cache)); +} + +/* Next two functions are used for polymorphic inline caching */ + +CELL object_class(CELL object) +{ + if(!HI_TAG_OR_TUPLE_P(object)) + return tag_fixnum(TAG(object)); + else + return get(HI_TAG_HEADER(object)); +} + +CELL lookup_method(CELL object, CELL methods) +{ + if(!HI_TAG_OR_TUPLE_P(object)) + return array_nth(untag_object(methods),TAG(object)); + else + return lookup_hairy_method(object,methods); } diff --git a/vm/inline_cache.c b/vm/inline_cache.c new file mode 100644 index 0000000000..08b3e9bc77 --- /dev/null +++ b/vm/inline_cache.c @@ -0,0 +1,182 @@ +#include "master.h" + +/* Figure out what kind of type check the PIC needs based on the methods +it contains */ +static CELL determine_inline_cache_type(CELL cache_entries) +{ + F_ARRAY *array = untag_object(cache_entries); + + bool seen_hi_tag = false, seen_tuple = false; + + CELL i; + for(i = 0; i < array_capacity(array); i += 2) + { + CELL class = array_nth(array,i); + F_FIXNUM type; + + /* Is it a tuple layout? */ + switch(type_of(class)) + { + case FIXNUM_TYPE: + type = untag_fixnum_fast(class); + if(type >= HEADER_TYPE) + seen_hi_tag = true; + break; + case ARRAY_TYPE: + seen_tuple = true; + break; + default: + critical_error("Expected a fixnum or array",class); + break; + } + } + + if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE; + if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG; + if(!seen_hi_tag && seen_tuple) return PIC_TUPLE; + if(!seen_hi_tag && !seen_tuple) return PIC_TAG; + + critical_error("Oops",0); + return -1; +} + +/* picker: one of dup, over, pick + cache_entries: array of class/method pairs */ +static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL cache_entries) +{ + REGISTER_ROOT(picker); + REGISTER_ROOT(generic_word); + REGISTER_ROOT(cache_entries); + + F_JIT jit; + jit_init(&jit,WORD_TYPE,generic_word); + + /* Generate machine code to determine the object's class. */ + jit_emit_subprimitive(&jit,untag_object(picker)); + jit_emit(&jit,userenv[determine_inline_cache_type(cache_entries)]); + + /* Generate machine code to check, in turn, if the class is one of the cached entries. */ + CELL i; + for(i = 0; i < array_capacity(untag_object(cache_entries)); i += 2) + { + /* Class equal? */ + CELL class = array_nth(untag_object(cache_entries),i); + jit_emit_with(&jit,userenv[PIC_CHECK],class); + + /* Yes? Jump to method */ + CELL method = array_nth(untag_object(cache_entries),i + 1); + jit_emit_with(&jit,userenv[PIC_HIT],method); + } + + /* Generate machine code to handle a cache miss, which ultimately results in + this function being called again. + + The inline-cache-miss primitive call receives enough information to + reconstruct the PIC. We also execute the picker again, so that the + object being dispatched on can be popped from the top of the stack. */ + jit_emit_subprimitive(&jit,untag_object(picker)); + jit_push(&jit,generic_word); + jit_push(&jit,cache_entries); + jit_word_jump(&jit,userenv[PIC_MISS_WORD]); + + F_CODE_BLOCK *code = jit_make_code_block(&jit); + jit_dispose(&jit); + + UNREGISTER_ROOT(cache_entries); + UNREGISTER_ROOT(generic_word); + UNREGISTER_ROOT(picker); + + return code; +} + +/* A generic word's definition performs general method lookup. Allocates memory */ +static F_CODE_BLOCK *megamorphic_call_stub(CELL generic_word) +{ + F_WORD *word = untag_word(generic_word); + REGISTER_UNTAGGED(word); + jit_compile(word->def,true); + UNREGISTER_UNTAGGED(word); + return untag_quotation(word->def)->code; +} + +/* Assumes that generic word definitions look like: + [ lookup-method (execute) ] +*/ +static void examine_generic_word(CELL generic_word, CELL *picker, CELL *all_methods) +{ + CELL def = untag_word(generic_word)->def; + F_QUOTATION *quot = untag_quotation(def); + F_ARRAY *array = untag_object(quot->array); + +#ifdef FACTOR_DEBUG + assert(array_capacity(array) == 5); + type_check(WORD_TYPE,array_nth(array,0)); + type_check(ARRAY_TYPE,array_nth(array,1)); + type_check(ARRAY_TYPE,array_nth(array,2)); + type_check(WORD_TYPE,array_nth(array,3)); + type_check(WORD_TYPE,array_nth(array,4)); +#endif + + *picker = array_nth(array,0); + *all_methods = array_nth(array,1); +} + +/* Allocates memory */ +static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method) +{ + F_ARRAY *cache_entries_array = untag_object(cache_entries); + CELL pic_size = array_capacity(cache_entries_array); + cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); + set_array_nth(cache_entries_array,pic_size,class); + set_array_nth(cache_entries_array,pic_size + 1,method); + return tag_object(cache_entries_array); +} + +/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss). +Called from assembly with the actual return address */ +F_FASTCALL XT inline_cache_miss(CELL return_address) +{ + CELL cache_entries = dpop(); + CELL generic_word = dpop(); + CELL object = dpop(); + + F_CODE_BLOCK *block; + + CELL pic_size = (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries))); + + if(pic_size >= max_pic_size) + block = megamorphic_call_stub(generic_word); + else + { + CELL picker, all_methods; + examine_generic_word(generic_word,&picker,&all_methods); + + REGISTER_ROOT(generic_word); + REGISTER_ROOT(cache_entries); + REGISTER_ROOT(picker); + REGISTER_ROOT(all_methods); + + /* Find the right method. */ + CELL class = object_class(object); + CELL method = lookup_method(object,all_methods); + + /* Add a new entry to the PIC. */ + if(cache_entries == F) + cache_entries = allot_array_2(class,method); + else + cache_entries = add_inline_cache_entry(cache_entries,class,method); + + /* Install the new PIC. */ + block = compile_inline_cache(picker,generic_word,cache_entries); + + UNREGISTER_ROOT(all_methods); + UNREGISTER_ROOT(picker); + UNREGISTER_ROOT(cache_entries); + UNREGISTER_ROOT(generic_word); + } + + XT xt = (block + 1); + set_call_site(return_address,(CELL)xt); + + return xt; +} diff --git a/vm/inline_cache.h b/vm/inline_cache.h new file mode 100644 index 0000000000..f924c2c59e --- /dev/null +++ b/vm/inline_cache.h @@ -0,0 +1,8 @@ +int max_pic_size; + +void primitive_inline_cache_miss(void); + +F_FASTCALL XT inline_cache_miss(CELL return_address); + +CELL object_class(CELL object); +CELL lookup_method(CELL object, CELL methods); diff --git a/vm/jit.h b/vm/jit.h index deafb48308..a8738eb835 100644 --- a/vm/jit.h +++ b/vm/jit.h @@ -44,3 +44,14 @@ INLINE void jit_word_jump(F_JIT *jit, CELL word) { jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); } + +/* Allocates memory */ +INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word) +{ + REGISTER_UNTAGGED(word); + if(array_nth(untag_object(word->subprimitive),1) != F) + jit_add_literal(jit,T); + UNREGISTER_UNTAGGED(word); + + jit_emit(jit,word->subprimitive); +} diff --git a/vm/master.h b/vm/master.h index c89d6d2092..c6f2c0a090 100644 --- a/vm/master.h +++ b/vm/master.h @@ -47,6 +47,7 @@ #include "quotations.h" #include "dispatch.h" #include "jit.h" +#include "inline_cache.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 4281e88fc3..dfdc99f487 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -145,5 +145,6 @@ void *primitives[] = { primitive_jit_compile, primitive_load_locals, primitive_check_datastack, - primitive_lookup_method + primitive_lookup_method, + primitive_inline_cache_miss, }; diff --git a/vm/quotations.c b/vm/quotations.c index d149dab6c9..6860e3acba 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -168,14 +168,7 @@ void jit_compile(CELL quot, bool relocate) /* Intrinsics */ if(word->subprimitive != F) - { - REGISTER_UNTAGGED(word); - if(array_nth(untag_object(word->subprimitive),1) != F) - jit_add_literal(&jit,T); - UNREGISTER_UNTAGGED(word); - - jit_emit(&jit,word->subprimitive); - } + jit_emit_subprimitive(&jit,word); /* The (execute) primitive is special-cased */ else if(obj == userenv[JIT_EXECUTE_WORD]) { diff --git a/vm/run.h b/vm/run.h index ba183fb6d4..2e15365dbd 100755 --- a/vm/run.h +++ b/vm/run.h @@ -48,7 +48,7 @@ typedef enum { JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DECLARE_WORD = 42, + JIT_DECLARE_WORD, JIT_SAVE_STACK, JIT_DIP_WORD, JIT_DIP, @@ -60,6 +60,15 @@ typedef enum { JIT_EXECUTE_JUMP, JIT_EXECUTE_CALL, + /* Used by polymorphic inline cache generation in inline_cache.c */ + PIC_TAG = 53, + PIC_HI_TAG, + PIC_TUPLE, + PIC_HI_TAG_TUPLE, + PIC_CHECK, + PIC_HIT, + PIC_MISS_WORD, + STACK_TRACES_ENV = 59, UNDEFINED_ENV = 60, /* default quotation for undefined words */ diff --git a/vm/types.c b/vm/types.c index 64f545dec5..b5981dc3b1 100755 --- a/vm/types.c +++ b/vm/types.c @@ -172,7 +172,8 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) { #ifdef FACTOR_DEBUG - assert(untag_header(array->header) == ARRAY_TYPE); + CELL header = untag_header(array->header); + assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); #endif CELL to_copy = array_capacity(array); From bd1b6be732bfdf2d94f022214d4da55c3686b34f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 04:03:11 -0500 Subject: [PATCH 26/83] Remove some unused macros --- vm/types.h | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/vm/types.h b/vm/types.h index f3039f945c..f881261dce 100755 --- a/vm/types.h +++ b/vm/types.h @@ -223,22 +223,9 @@ INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) return result; } -#define GROWABLE_BYTE_ARRAY(result) \ - F_GROWABLE_BYTE_ARRAY result##_g = make_growable_byte_array(); \ - REGISTER_ROOT(result##_g.array) - void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); -#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \ - growable_byte_array_append(&result##_g,elts,len) - INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) { byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); } - -#define GROWABLE_BYTE_ARRAY_TRIM(result) growable_byte_array_trim(&result##_g) - -#define GROWABLE_BYTE_ARRAY_DONE(result) \ - UNREGISTER_ROOT(result##_g.array); \ - CELL result = result##_g.array; From e940f6fd8b53a473fc1e0fa1886e7ddb55ebb246 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 16:58:05 -0500 Subject: [PATCH 27/83] Add method dispatch statistics --- .../known-words/known-words.factor | 7 +- core/bootstrap/primitives.factor | 5 ++ vm/dispatch.c | 22 +++++ vm/dispatch.h | 9 +- vm/inline_cache.c | 85 +++++++++++++++---- vm/inline_cache.h | 17 +++- vm/primitives.c | 4 + 7 files changed, 126 insertions(+), 23 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 56c59c8759..c79bcde518 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -671,4 +671,9 @@ M: object infer-call* \ jit-compile { quotation } { } define-primitive -\ lookup-method { object array } { word } define-primitive \ No newline at end of file +\ lookup-method { object array } { word } define-primitive + +\ reset-dispatch-stats { } { } define-primitive +\ dispatch-stats { } { array } define-primitive +\ reset-inline-cache-stats { } { } define-primitive +\ inline-cache-stats { } { array } define-primitive \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b618e64d41..41242e3c39 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,6 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.single" "generic.single.private" "growable" "hashtables" @@ -534,6 +535,10 @@ tuple { "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) } { "inline-cache-miss" "generic.single.private" (( generic methods -- )) } + { "reset-dispatch-stats" "generic.single" (( -- )) } + { "dispatch-stats" "generic.single" (( -- stats )) } + { "reset-inline-cache-stats" "generic.single" (( -- )) } + { "inline-cache-stats" "generic.single" (( -- stats )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/vm/dispatch.c b/vm/dispatch.c index 8093912080..492b29ac17 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -126,15 +126,22 @@ static CELL lookup_hairy_method(CELL object, CELL methods) static CELL lookup_method_with_cache(CELL object, CELL methods, CELL method_cache) { if(!HI_TAG_OR_TUPLE_P(object)) + { + megamorphic_cache_hits++; return array_nth(untag_object(methods),TAG(object)); + } else { CELL key = get(HI_TAG_HEADER(object)); CELL method = lookup_cached_method(key,method_cache); if(method != F) + { + megamorphic_cache_hits++; return method; + } else { + megamorphic_cache_misses++; method = lookup_hairy_method(object,methods); update_method_cache(key,method_cache,method); return method; @@ -168,3 +175,18 @@ CELL lookup_method(CELL object, CELL methods) else return lookup_hairy_method(object,methods); } + +void primitive_reset_dispatch_stats(void) +{ + megamorphic_cache_hits = megamorphic_cache_misses = 0; +} + +void primitive_dispatch_stats(void) +{ + GROWABLE_ARRAY(stats); + GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits)); + GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses)); + GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); + dpush(stats); +} diff --git a/vm/dispatch.h b/vm/dispatch.h index 5d783f488d..a05460dd7e 100644 --- a/vm/dispatch.h +++ b/vm/dispatch.h @@ -1,3 +1,10 @@ -u64 local_cache_misses; +CELL megamorphic_cache_hits; +CELL megamorphic_cache_misses; void primitive_lookup_method(void); + +CELL object_class(CELL object); +CELL lookup_method(CELL object, CELL methods); + +void primitive_reset_dispatch_stats(void); +void primitive_dispatch_stats(void); diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 08b3e9bc77..694194c6f3 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -1,5 +1,10 @@ #include "master.h" +void init_inline_caching(int max_size) +{ + max_pic_size = max_size; +} + /* Figure out what kind of type check the PIC needs based on the methods it contains */ static CELL determine_inline_cache_type(CELL cache_entries) @@ -40,6 +45,11 @@ static CELL determine_inline_cache_type(CELL cache_entries) return -1; } +static void update_pic_count(CELL type) +{ + pic_counts[type - PIC_TAG]++; +} + /* picker: one of dup, over, pick cache_entries: array of class/method pairs */ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL cache_entries) @@ -48,12 +58,16 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL c REGISTER_ROOT(generic_word); REGISTER_ROOT(cache_entries); + CELL inline_cache_type = determine_inline_cache_type(cache_entries); + + update_pic_count(inline_cache_type); + F_JIT jit; jit_init(&jit,WORD_TYPE,generic_word); /* Generate machine code to determine the object's class. */ jit_emit_subprimitive(&jit,untag_object(picker)); - jit_emit(&jit,userenv[determine_inline_cache_type(cache_entries)]); + jit_emit(&jit,userenv[inline_cache_type]); /* Generate machine code to check, in turn, if the class is one of the cached entries. */ CELL i; @@ -121,20 +135,40 @@ static void examine_generic_word(CELL generic_word, CELL *picker, CELL *all_meth *all_methods = array_nth(array,1); } +static CELL inline_cache_size(CELL cache_entries) +{ + return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries))); +} + /* Allocates memory */ static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method) { - F_ARRAY *cache_entries_array = untag_object(cache_entries); - CELL pic_size = array_capacity(cache_entries_array); - cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); - set_array_nth(cache_entries_array,pic_size,class); - set_array_nth(cache_entries_array,pic_size + 1,method); - return tag_object(cache_entries_array); + if(cache_entries == F) + return allot_array_2(class,method); + else + { + F_ARRAY *cache_entries_array = untag_object(cache_entries); + CELL pic_size = array_capacity(cache_entries_array); + cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); + set_array_nth(cache_entries_array,pic_size,class); + set_array_nth(cache_entries_array,pic_size + 1,method); + return tag_object(cache_entries_array); + } +} + +static void update_pic_transitions(CELL pic_size) +{ + if(pic_size == max_pic_size) + pic_to_mega_transitions++; + else if(pic_size == 0) + cold_call_to_ic_transitions++; + else if(pic_size == 1) + ic_to_pic_transitions++; } /* The cache_entries parameter is either f (on cold call site) or an array (on cache miss). Called from assembly with the actual return address */ -F_FASTCALL XT inline_cache_miss(CELL return_address) +XT inline_cache_miss(CELL return_address) { CELL cache_entries = dpop(); CELL generic_word = dpop(); @@ -142,7 +176,9 @@ F_FASTCALL XT inline_cache_miss(CELL return_address) F_CODE_BLOCK *block; - CELL pic_size = (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries))); + CELL pic_size = inline_cache_size(cache_entries); + + update_pic_transitions(pic_size); if(pic_size >= max_pic_size) block = megamorphic_call_stub(generic_word); @@ -156,17 +192,10 @@ F_FASTCALL XT inline_cache_miss(CELL return_address) REGISTER_ROOT(picker); REGISTER_ROOT(all_methods); - /* Find the right method. */ CELL class = object_class(object); CELL method = lookup_method(object,all_methods); - /* Add a new entry to the PIC. */ - if(cache_entries == F) - cache_entries = allot_array_2(class,method); - else - cache_entries = add_inline_cache_entry(cache_entries,class,method); - - /* Install the new PIC. */ + cache_entries = add_inline_cache_entry(cache_entries,class,method); block = compile_inline_cache(picker,generic_word,cache_entries); UNREGISTER_ROOT(all_methods); @@ -175,8 +204,30 @@ F_FASTCALL XT inline_cache_miss(CELL return_address) UNREGISTER_ROOT(generic_word); } + /* Install the new stub. */ XT xt = (block + 1); set_call_site(return_address,(CELL)xt); return xt; } + +void primitive_reset_inline_cache_stats(void) +{ + cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0; + CELL i; + for(i = 0; i < 4; i++) pic_counts[i] = 0; +} + +void primitive_inline_cache_stats(void) +{ + GROWABLE_ARRAY(stats); + GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions)); + GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions)); + GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions)); + CELL i; + for(i = 0; i < 4; i++) + GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i])); + GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); + dpush(stats); +} diff --git a/vm/inline_cache.h b/vm/inline_cache.h index f924c2c59e..83f2644f5a 100644 --- a/vm/inline_cache.h +++ b/vm/inline_cache.h @@ -1,8 +1,17 @@ -int max_pic_size; +CELL max_pic_size; + +CELL cold_call_to_ic_transitions; +CELL ic_to_pic_transitions; +CELL pic_to_mega_transitions; + +/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */ +CELL pic_counts[4]; + +void init_inline_caching(int max_size); void primitive_inline_cache_miss(void); -F_FASTCALL XT inline_cache_miss(CELL return_address); +XT inline_cache_miss(CELL return_address); -CELL object_class(CELL object); -CELL lookup_method(CELL object, CELL methods); +void primitive_reset_inline_cache_stats(void); +void primitive_inline_cache_stats(void); diff --git a/vm/primitives.c b/vm/primitives.c index dfdc99f487..9159ebd48f 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -147,4 +147,8 @@ void *primitives[] = { primitive_check_datastack, primitive_lookup_method, primitive_inline_cache_miss, + primitive_reset_dispatch_stats, + primitive_dispatch_stats, + primitive_reset_inline_cache_stats, + primitive_inline_cache_stats, }; From 3985b180269edbf1ca5b8c1a34bac2a98fbb09e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 16:58:19 -0500 Subject: [PATCH 28/83] Add -pic= command line argument --- basis/command-line/command-line-docs.factor | 4 ++-- vm/factor.c | 4 ++++ vm/image.h | 1 + 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 3d06bd97b7..5aeb49d6f2 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax parser vocabs.loader strings -command-line.private ; +USING: help.markup help.syntax parser vocabs.loader strings ; IN: command-line HELP: run-bootstrap-init @@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } + { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } "If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ; diff --git a/vm/factor.c b/vm/factor.c index 27ec80a4eb..1010e923ea 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -66,6 +66,7 @@ void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size)); else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size)); else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size)); else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true; else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true; else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3; @@ -99,6 +100,8 @@ void init_factor(F_PARAMETERS *p) p->tenured_size <<= 20; p->code_size <<= 20; + p->max_pic_size = 3; + /* Disable GC during init as a sanity check */ gc_off = true; @@ -118,6 +121,7 @@ void init_factor(F_PARAMETERS *p) init_stacks(p->ds_size,p->rs_size); load_image(p); init_c_io(); + init_inline_caching(p->max_pic_size); #ifndef FACTOR_DEBUG init_signals(); diff --git a/vm/image.h b/vm/image.h index e26a6bb5b4..de5b55f0af 100755 --- a/vm/image.h +++ b/vm/image.h @@ -35,6 +35,7 @@ typedef struct { bool fep; bool console; bool stack_traces; + CELL max_pic_size; } F_PARAMETERS; void load_image(F_PARAMETERS *p); From e8008af5d09b6beb31a3e1eba7d13b8de549c1e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 16:58:38 -0500 Subject: [PATCH 29/83] inline-cache-miss primitive now jumps to the new stub --- vm/cpu-x86.32.S | 9 +++++++++ vm/cpu-x86.64.S | 8 ++++++++ vm/cpu-x86.S | 4 ---- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 22228eb6d9..2b4a736228 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -30,6 +30,7 @@ and the callstack top is passed in EDX */ pop %ebx #define QUOT_XT_OFFSET 14 +#define WORD_XT_OFFSET 30 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative @@ -59,6 +60,14 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret +DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): + mov (%esp),%eax + sub $8,%esp + push %eax + call MANGLE(inline_cache_miss) + add $12,%esp + jmp *WORD_XT_OFFSET(%eax) + #include "cpu-x86.S" #ifdef WINDOWS diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index ba1f5b5409..984f7d1842 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -62,6 +62,7 @@ #endif #define QUOT_XT_OFFSET 34 +#define WORD_XT_OFFSET 66 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative @@ -72,4 +73,11 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ +DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): + mov (%rsp),ARG0 + sub $STACK_PADDING,%rsp + call MANGLE(inline_cache_miss) + add $STACK_PADDING,%rsp + jmp *WORD_XT_OFFSET(%rax) + #include "cpu-x86.S" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 5dfc55cbd5..e83bb0fd7d 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -68,10 +68,6 @@ DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)): add $STACK_PADDING,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (STACK_REG),ARG0 - jmp MANGLE(inline_cache_miss) - #ifdef WINDOWS .section .drectve .ascii " -export:c_to_factor" From 5f6c074edd8b9ecd1debe9a23cf1d6cd81552f78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 17:26:11 -0500 Subject: [PATCH 30/83] Split up types.c/h into smaller files, remove optimized slot from F_WORD struct --- Makefile | 9 +- .../remote-control/remote-control.factor | 2 +- basis/bootstrap/compiler/compiler.factor | 2 +- basis/bootstrap/stage2.factor | 4 - basis/compiler/compiler.factor | 2 +- basis/compiler/tests/codegen.factor | 2 +- basis/compiler/tests/optimizer.factor | 14 +- basis/compiler/tests/peg-regression.factor | 4 +- basis/compiler/tests/redefine3.factor | 4 +- basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/spilling.factor | 6 +- basis/locals/locals-tests.factor | 2 +- .../call-effect/call-effect.factor | 2 +- .../known-words/known-words.factor | 4 +- basis/tools/walker/walker-tests.factor | 2 +- core/bootstrap/primitives.factor | 5 +- core/combinators/combinators-tests.factor | 8 +- vm/arrays.c | 146 ++++ vm/arrays.h | 90 +++ vm/booleans.c | 13 + vm/booleans.h | 7 + vm/byte_arrays.c | 73 ++ vm/byte_arrays.h | 40 ++ vm/callstack.h | 7 + vm/code_heap.c | 12 +- vm/code_heap.h | 2 - vm/layouts.h | 5 +- vm/master.h | 7 +- vm/primitives.c | 1 + vm/profiler.c | 21 +- vm/profiler.h | 2 +- vm/quotations.c | 2 +- vm/quotations.h | 2 + vm/run.c | 22 + vm/run.h | 6 +- vm/strings.c | 274 ++++++++ vm/strings.h | 50 ++ vm/tuples.c | 35 + vm/tuples.h | 25 + vm/types.c | 623 ------------------ vm/types.h | 231 ------- vm/words.c | 82 +++ vm/words.h | 16 + 43 files changed, 935 insertions(+), 933 deletions(-) create mode 100644 vm/arrays.c create mode 100644 vm/arrays.h create mode 100644 vm/booleans.c create mode 100644 vm/booleans.h create mode 100644 vm/byte_arrays.c create mode 100644 vm/byte_arrays.h create mode 100644 vm/strings.c create mode 100644 vm/strings.h create mode 100644 vm/tuples.c create mode 100644 vm/tuples.h delete mode 100755 vm/types.c delete mode 100755 vm/types.h create mode 100644 vm/words.c create mode 100644 vm/words.h diff --git a/Makefile b/Makefile index d5c7e00763..9053626291 100644 --- a/Makefile +++ b/Makefile @@ -28,7 +28,10 @@ endif DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/alien.o \ + vm/arrays.o \ vm/bignum.o \ + vm/booleans.o \ + vm/byte_arrays.o \ vm/callstack.o \ vm/code_block.o \ vm/code_gc.o \ @@ -48,8 +51,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/profiler.o \ vm/quotations.o \ vm/run.o \ - vm/types.o \ - vm/utilities.o + vm/strings.o \ + vm/tuples.o \ + vm/utilities.o \ + vm/words.o EXE_OBJS = $(PLAF_EXE_OBJS) diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 4da06ec4c9..b72c79e478 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup optimized>> [ execute ] [ drop f ] if ; inline + dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 3eda3bcc37..6e82e16268 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -29,7 +29,7 @@ enable-compiler gc : compile-unoptimized ( words -- ) - [ optimized>> not ] filter compile ; + [ optimized? not ] filter compile ; nl "Compiling..." write flush diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index cc853e4842..14c08c070a 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -35,10 +35,6 @@ SYMBOL: bootstrap-time "Core bootstrap completed in " write core-bootstrap-time get print-time "Bootstrap completed in " write bootstrap-time get print-time - [ optimized>> ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - "Bootstrapping is complete." print "Now, you can run Factor:" print vm write " -i=" write "output-image" get print flush ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e8a38b147e..6783b728e4 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -122,7 +122,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; : compile-dependency ( word -- ) #! If a word calls an unoptimized word, try to compile the callee. - dup optimized>> [ drop ] [ queue-compile ] if ; + dup optimized? [ drop ] [ queue-compile ] if ; ! Only switch this off for debugging. SYMBOL: compile-dependencies? diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index c746fdfb45..611371a457 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -211,7 +211,7 @@ TUPLE: my-tuple ; { tuple vector } 3 slot { word } declare dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; -[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test +[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index bd7008f909..af0f029800 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -10,7 +10,7 @@ IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz optimized>> ] unit-test +[ t ] [ \ xyz optimized? ] unit-test ! Test predicate inlining : pred-test-1 ( a -- b c ) @@ -95,7 +95,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage optimized>> ] unit-test +[ t ] [ \ breakage optimized? ] unit-test [ breakage ] must-fail ! regression @@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression optimized>> ] unit-test +[ t ] [ \ -regression optimized? ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; @@ -229,7 +229,7 @@ USE: binary-search.private : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; -[ t ] [ \ node-successor-f-bug optimized>> ] unit-test +[ t ] [ \ node-successor-f-bug optimized? ] unit-test [ ] [ [ new ] build-tree optimize-tree drop ] unit-test @@ -243,7 +243,7 @@ USE: binary-search.private ] if ] if ; -[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test +[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test @@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ; : recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; -[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test +[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test DEFER: recursive-inline-hang-3 @@ -325,7 +325,7 @@ PREDICATE: list < improper-list dup "a" get { array-capacity } declare >= [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; -[ t ] [ \ interval-inference-bug optimized>> ] unit-test +[ t ] [ \ interval-inference-bug optimized? ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index e107135305..da2f3fa604 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]] USE: tools.test -[ t ] [ \ expr optimized>> ] unit-test -[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test +[ t ] [ \ expr optimized? ] unit-test +[ t ] [ \ ast>pipeline-expr optimized? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 51ce33c1bd..0a5eb84579 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test optimized>> ] unit-test +[ t ] [ \ sheeple-test optimized? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test @@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ; [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test optimized>> ] unit-test +[ t ] [ \ sheeple-test optimized? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 82cc97e0f6..88dc9a53b1 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj ) ] unit-test ] times diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 2ec6fbde95..b0039132a0 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -47,7 +47,7 @@ IN: compiler.tests.spilling [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] [ 1.0 float-spill-bug ] unit-test -[ t ] [ \ float-spill-bug optimized>> ] unit-test +[ t ] [ \ float-spill-bug optimized? ] unit-test : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) { @@ -132,7 +132,7 @@ IN: compiler.tests.spilling [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] [ 1.0 float-fixnum-spill-bug ] unit-test -[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test +[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test : resolve-spill-bug ( a b -- c ) [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ @@ -159,7 +159,7 @@ IN: compiler.tests.spilling 16 narray ] if ; -[ t ] [ \ resolve-spill-bug optimized>> ] unit-test +[ t ] [ \ resolve-spill-bug optimized? ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 68fa8dbda0..1549a77663 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -585,4 +585,4 @@ M: integer ed's-bug neg ; :: ed's-test-case ( a -- b ) { [ a ed's-bug ] } && ; -[ t ] [ \ ed's-test-case optimized>> ] unit-test +[ t ] [ \ ed's-test-case optimized? ] unit-test diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index 100088f174..daeecc3ad5 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -79,7 +79,7 @@ M: quotation cached-effect [ '[ _ execute ] ] dip call-effect-slow ; inline : execute-effect-unsafe? ( word effect -- ? ) - over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline + over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline : execute-effect-fast ( word effect inline-cache -- ) 2over execute-effect-unsafe? diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c79bcde518..0bbaa32c25 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -676,4 +676,6 @@ M: object infer-call* \ reset-dispatch-stats { } { } define-primitive \ dispatch-stats { } { array } define-primitive \ reset-inline-cache-stats { } { } define-primitive -\ inline-cache-stats { } { array } define-primitive \ No newline at end of file +\ inline-cache-stats { } { array } define-primitive + +\ optimized? { word } { object } define-primitive \ No newline at end of file diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 6dabb73e30..c8ab2512f6 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -118,7 +118,7 @@ IN: tools.walker.tests \ breakpoint-test don't-step-into -[ f ] [ \ breakpoint-test optimized>> ] unit-test +[ f ] [ \ breakpoint-test optimized? ] unit-test [ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 41242e3c39..a3b4a91aeb 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math math.private math.order @@ -259,7 +259,7 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "optimized" read-only } + { "direct-entry-def" } { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -539,6 +539,7 @@ tuple { "dispatch-stats" "generic.single" (( -- stats )) } { "reset-inline-cache-stats" "generic.single" (( -- )) } { "inline-cache-stats" "generic.single" (( -- stats )) } + { "optimized?" "words" (( word -- ? )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index dd5fa06031..aae6618ee8 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -16,12 +16,12 @@ IN: combinators.tests : compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; -[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test +[ t ] [ \ compile-execute(-test-1 optimized? ] unit-test [ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test : compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; -[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test +[ t ] [ \ compile-execute(-test-2 optimized? ] unit-test [ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test @@ -29,7 +29,7 @@ IN: combinators.tests : compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ; -[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test +[ t ] [ \ compile-call(-test-1 optimized? ] unit-test [ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test @@ -352,7 +352,7 @@ DEFER: corner-case-1 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >> -[ t ] [ \ corner-case-1 optimized>> ] unit-test +[ t ] [ \ corner-case-1 optimized? ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test diff --git a/vm/arrays.c b/vm/arrays.c new file mode 100644 index 0000000000..3f0de35262 --- /dev/null +++ b/vm/arrays.c @@ -0,0 +1,146 @@ +#include "master.h" + +/* the array is full of undefined data, and must be correctly filled before the +next GC. size is in cells */ +F_ARRAY *allot_array_internal(CELL type, CELL capacity) +{ + F_ARRAY *array = allot_object(type,array_size(capacity)); + array->capacity = tag_fixnum(capacity); + return array; +} + +/* make a new array with an initial element */ +F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) +{ + int i; + REGISTER_ROOT(fill); + F_ARRAY* array = allot_array_internal(type, capacity); + UNREGISTER_ROOT(fill); + if(fill == 0) + memset((void*)AREF(array,0),'\0',capacity * CELLS); + else + { + /* No need for write barrier here. Either the object is in + the nursery, or it was allocated directly in tenured space + and the write barrier is already hit for us in that case. */ + for(i = 0; i < capacity; i++) + put(AREF(array,i),fill); + } + return array; +} + +/* push a new array on the stack */ +void primitive_array(void) +{ + CELL initial = dpop(); + CELL size = unbox_array_size(); + dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); +} + +CELL allot_array_1(CELL obj) +{ + REGISTER_ROOT(obj); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); + UNREGISTER_ROOT(obj); + set_array_nth(a,0,obj); + return tag_object(a); +} + +CELL allot_array_2(CELL v1, CELL v2) +{ + REGISTER_ROOT(v1); + REGISTER_ROOT(v2); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2); + UNREGISTER_ROOT(v2); + UNREGISTER_ROOT(v1); + set_array_nth(a,0,v1); + set_array_nth(a,1,v2); + return tag_object(a); +} + +CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) +{ + REGISTER_ROOT(v1); + REGISTER_ROOT(v2); + REGISTER_ROOT(v3); + REGISTER_ROOT(v4); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4); + UNREGISTER_ROOT(v4); + UNREGISTER_ROOT(v3); + UNREGISTER_ROOT(v2); + UNREGISTER_ROOT(v1); + set_array_nth(a,0,v1); + set_array_nth(a,1,v2); + set_array_nth(a,2,v3); + set_array_nth(a,3,v4); + return tag_object(a); +} + +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); +#endif + + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * CELLS); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); + + return new_array; +} + +void primitive_resize_array(void) +{ + F_ARRAY* array = untag_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_array(array,capacity))); +} + +void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) +{ + F_ARRAY *underlying = untag_object(array->array); + REGISTER_ROOT(elt); + + if(array->count == array_capacity(underlying)) + { + underlying = reallot_array(underlying,array->count * 2); + array->array = tag_object(underlying); + } + + UNREGISTER_ROOT(elt); + set_array_nth(underlying,array->count++,elt); +} + +void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) +{ + REGISTER_UNTAGGED(elts); + + F_ARRAY *underlying = untag_object(array->array); + + CELL elts_size = array_capacity(elts); + CELL new_size = array->count + elts_size; + + if(new_size >= array_capacity(underlying)) + { + underlying = reallot_array(underlying,new_size * 2); + array->array = tag_object(underlying); + } + + UNREGISTER_UNTAGGED(elts); + + write_barrier(array->array); + + memcpy((void *)AREF(underlying,array->count), + (void *)AREF(elts,0), + elts_size * CELLS); + + array->count += elts_size; +} diff --git a/vm/arrays.h b/vm/arrays.h new file mode 100644 index 0000000000..4d773922b4 --- /dev/null +++ b/vm/arrays.h @@ -0,0 +1,90 @@ +DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) + +/* Inline functions */ +INLINE CELL array_size(CELL size) +{ + return sizeof(F_ARRAY) + size * CELLS; +} + +INLINE CELL array_capacity(F_ARRAY* array) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE); +#endif + return array->capacity >> TAG_BITS; +} + +#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) +#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) + +INLINE CELL array_nth(F_ARRAY *array, CELL slot) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == ARRAY_TYPE); +#endif + return get(AREF(array,slot)); +} + +INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == ARRAY_TYPE); +#endif + put(AREF(array,slot),value); + write_barrier((CELL)array); +} + +F_ARRAY *allot_array_internal(CELL type, CELL capacity); +F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); +F_BYTE_ARRAY *allot_byte_array(CELL size); + +CELL allot_array_1(CELL obj); +CELL allot_array_2(CELL v1, CELL v2); +CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); + +void primitive_array(void); + +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); +void primitive_resize_array(void); + +/* Macros to simulate a vector in C */ +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_ARRAY; + +/* Allocates memory */ +INLINE F_GROWABLE_ARRAY make_growable_array(void) +{ + F_GROWABLE_ARRAY result; + result.count = 0; + result.array = tag_object(allot_array(ARRAY_TYPE,100,F)); + return result; +} + +#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ + REGISTER_ROOT(result##_g.array) + +void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); + +#define GROWABLE_ARRAY_ADD(result,elt) \ + growable_array_add(&result##_g,elt) + +void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); + +#define GROWABLE_ARRAY_APPEND(result,elts) \ + growable_array_append(&result##_g,elts) + +INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) +{ + array->array = tag_object(reallot_array(untag_object(array->array),array->count)); +} + +#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) + +#define GROWABLE_ARRAY_DONE(result) \ + UNREGISTER_ROOT(result##_g.array); \ + CELL result = result##_g.array; diff --git a/vm/booleans.c b/vm/booleans.c new file mode 100644 index 0000000000..113265873f --- /dev/null +++ b/vm/booleans.c @@ -0,0 +1,13 @@ +#include "master.h" + +/* FFI calls this */ +void box_boolean(bool value) +{ + dpush(value ? T : F); +} + +/* FFI calls this */ +bool to_boolean(CELL value) +{ + return value != F; +} diff --git a/vm/booleans.h b/vm/booleans.h new file mode 100644 index 0000000000..ae49652dd8 --- /dev/null +++ b/vm/booleans.h @@ -0,0 +1,7 @@ +INLINE CELL tag_boolean(CELL untagged) +{ + return (untagged == false ? F : T); +} + +DLLEXPORT void box_boolean(bool value); +DLLEXPORT bool to_boolean(CELL value); diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c new file mode 100644 index 0000000000..42fd5ba274 --- /dev/null +++ b/vm/byte_arrays.c @@ -0,0 +1,73 @@ +#include "master.h" + +/* must fill out array before next GC */ +F_BYTE_ARRAY *allot_byte_array_internal(CELL size) +{ + F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, + byte_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +/* size is in bytes this time */ +F_BYTE_ARRAY *allot_byte_array(CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array_internal(size); + memset(array + 1,0,size); + return array; +} + +/* push a new byte array on the stack */ +void primitive_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array(size))); +} + +void primitive_uninitialized_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array_internal(size))); +} + +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) +{ +#ifdef FACTOR_DEBUG + assert(untag_header(array->header) == BYTE_ARRAY_TYPE); +#endif + + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy); + + return new_array; +} + +void primitive_resize_byte_array(void) +{ + F_BYTE_ARRAY* array = untag_byte_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_byte_array(array,capacity))); +} + +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) +{ + CELL new_size = array->count + len; + F_BYTE_ARRAY *underlying = untag_object(array->array); + + if(new_size >= byte_array_capacity(underlying)) + { + underlying = reallot_byte_array(underlying,new_size * 2); + array->array = tag_object(underlying); + } + + memcpy((void *)BREF(underlying,array->count),elts,len); + + array->count += len; +} diff --git a/vm/byte_arrays.h b/vm/byte_arrays.h new file mode 100644 index 0000000000..65c9731047 --- /dev/null +++ b/vm/byte_arrays.h @@ -0,0 +1,40 @@ +DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) + +INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) +{ + return untag_fixnum_fast(array->capacity); +} + +INLINE CELL byte_array_size(CELL size) +{ + return sizeof(F_BYTE_ARRAY) + size; +} + +F_BYTE_ARRAY *allot_byte_array(CELL size); +F_BYTE_ARRAY *allot_byte_array_internal(CELL size); +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); + +void primitive_byte_array(void); +void primitive_uninitialized_byte_array(void); +void primitive_resize_byte_array(void); + +/* Macros to simulate a byte vector in C */ +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_BYTE_ARRAY; + +INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) +{ + F_GROWABLE_BYTE_ARRAY result; + result.count = 0; + result.array = tag_object(allot_byte_array(100)); + return result; +} + +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); + +INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) +{ + byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); +} diff --git a/vm/callstack.h b/vm/callstack.h index 3c13e7b1cd..8b693c451c 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -1,3 +1,10 @@ +INLINE CELL callstack_size(CELL size) +{ + return sizeof(F_CALLSTACK) + size; +} + +DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) + F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) diff --git a/vm/code_heap.c b/vm/code_heap.c index 0c63abfbe0..f75fcb1ec5 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -12,15 +12,6 @@ bool in_code_heap_p(CELL ptr) && ptr <= code_heap.segment->end); } -void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled) -{ - if(compiled->block.type != WORD_TYPE) - critical_error("bad param to set_word_xt",(CELL)compiled); - - word->code = compiled; - word->optimizedp = T; -} - /* Compile a word definition with the non-optimizing compiler. Allocates memory */ void jit_compile_word(F_WORD *word, CELL def, bool relocate) { @@ -31,7 +22,6 @@ void jit_compile_word(F_WORD *word, CELL def, bool relocate) UNREGISTER_ROOT(def); word->code = untag_quotation(def)->code; - word->optimizedp = F; } /* Apply a function to every code block */ @@ -115,7 +105,7 @@ void primitive_modify_code_heap(void) UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); - set_word_code(word,compiled); + word->code = compiled; } else critical_error("Expected a quotation or an array",data); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4c5aafcddd..c0d44e8558 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -7,8 +7,6 @@ bool in_code_heap_p(CELL ptr); void jit_compile_word(F_WORD *word, CELL def, bool relocate); -void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled); - typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); void iterate_code_heap(CODE_HEAP_ITERATOR iter); diff --git a/vm/layouts.h b/vm/layouts.h index 266d790f2a..27bbe5b137 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -155,9 +155,8 @@ typedef struct { CELL def; /* TAGGED property assoc for library code */ CELL props; - /* TAGGED t or f, t means its compiled with the optimizing compiler, - f means its compiled with the non-optimizing compiler */ - CELL optimizedp; + /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ + CELL direct_entry_def; /* TAGGED call count for profiling */ CELL counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/master.h b/vm/master.h index c6f2c0a090..83c2d39c0f 100644 --- a/vm/master.h +++ b/vm/master.h @@ -34,7 +34,12 @@ #include "data_gc.h" #include "local_roots.h" #include "debug.h" -#include "types.h" +#include "arrays.h" +#include "strings.h" +#include "booleans.h" +#include "byte_arrays.h" +#include "tuples.h" +#include "words.h" #include "math.h" #include "float_bits.h" #include "io.h" diff --git a/vm/primitives.c b/vm/primitives.c index 9159ebd48f..3e9a829a2e 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -151,4 +151,5 @@ void *primitives[] = { primitive_dispatch_stats, primitive_reset_inline_cache_stats, primitive_inline_cache_stats, + primitive_optimized_p, }; diff --git a/vm/profiler.c b/vm/profiler.c index 7952a6b6f5..5578854d6d 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -1,7 +1,7 @@ #include "master.h" /* Allocates memory */ -static F_CODE_BLOCK *compile_profiling_stub(CELL word) +F_CODE_BLOCK *compile_profiling_stub(CELL word) { REGISTER_ROOT(word); F_JIT jit; @@ -13,25 +13,6 @@ static F_CODE_BLOCK *compile_profiling_stub(CELL word) return block; } -/* Allocates memory */ -void update_word_xt(F_WORD *word) -{ - if(profiling_p) - { - if(!word->profiling) - { - REGISTER_UNTAGGED(word); - F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); - UNREGISTER_UNTAGGED(word); - word->profiling = profiling; - } - - word->xt = (XT)(word->profiling + 1); - } - else - word->xt = (XT)(word->code + 1); -} - /* Allocates memory */ static void set_profiling(bool profiling) { diff --git a/vm/profiler.h b/vm/profiler.h index 481f75e966..40daab429c 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,3 +1,3 @@ bool profiling_p; +F_CODE_BLOCK *compile_profiling_stub(CELL word); void primitive_profiling(void); -void update_word_xt(F_WORD *word); diff --git a/vm/quotations.c b/vm/quotations.c index 6860e3acba..4b5eb0dd2c 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -461,7 +461,7 @@ void compile_all_words(void) F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - if(word->optimizedp == F) + if(!word->code || !word_optimized_p(word)) jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); diff --git a/vm/quotations.h b/vm/quotations.h index d571a90ed6..6fcd894b05 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,3 +1,5 @@ +DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) + void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vm/run.c b/vm/run.c index e55eb904a7..7dc2474113 100755 --- a/vm/run.c +++ b/vm/run.c @@ -224,3 +224,25 @@ void primitive_load_locals(void) ds -= CELLS * count; rs += CELLS * count; } + +static CELL clone_object(CELL object) +{ + CELL size = object_size(object); + if(size == 0) + return object; + else + { + REGISTER_ROOT(object); + void *new_obj = allot_object(type_of(object),size); + UNREGISTER_ROOT(object); + + CELL tag = TAG(object); + memcpy(new_obj,(void*)UNTAG(object),size); + return RETAG(new_obj,tag); + } +} + +void primitive_clone(void) +{ + drepl(clone_object(dpeek())); +} diff --git a/vm/run.h b/vm/run.h index 2e15365dbd..9a827d00ef 100755 --- a/vm/run.h +++ b/vm/run.h @@ -262,14 +262,10 @@ void primitive_check_datastack(void); void primitive_getenv(void); void primitive_setenv(void); void primitive_exit(void); -void primitive_os_env(void); -void primitive_os_envs(void); -void primitive_set_os_env(void); -void primitive_unset_os_env(void); -void primitive_set_os_envs(void); void primitive_micros(void); void primitive_sleep(void); void primitive_set_slot(void); void primitive_load_locals(void); +void primitive_clone(void); bool stage2; diff --git a/vm/strings.c b/vm/strings.c new file mode 100644 index 0000000000..03414077b9 --- /dev/null +++ b/vm/strings.c @@ -0,0 +1,274 @@ +#include "master.h" + +CELL string_nth(F_STRING* string, CELL index) +{ + /* If high bit is set, the most significant 16 bits of the char + come from the aux vector. The least significant bit of the + corresponding aux vector entry is negated, so that we can + XOR the two components together and get the original code point + back. */ + CELL ch = bget(SREF(string,index)); + if((ch & 0x80) == 0) + return ch; + else + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; + } +} + +void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) +{ + bput(SREF(string,index),ch); +} + +void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) +{ + F_BYTE_ARRAY *aux; + + bput(SREF(string,index),(ch & 0x7f) | 0x80); + + if(string->aux == F) + { + REGISTER_UNTAGGED(string); + /* We don't need to pre-initialize the + byte array with any data, since we + only ever read from the aux vector + if the most significant bit of a + character is set. Initially all of + the bits are clear. */ + aux = allot_byte_array_internal( + untag_fixnum_fast(string->length) + * sizeof(u16)); + UNREGISTER_UNTAGGED(string); + + write_barrier((CELL)string); + string->aux = tag_object(aux); + } + else + aux = untag_object(string->aux); + + cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); +} + +/* allocates memory */ +void set_string_nth(F_STRING* string, CELL index, CELL ch) +{ + if(ch <= 0x7f) + set_string_nth_fast(string,index,ch); + else + set_string_nth_slow(string,index,ch); +} + +/* untagged */ +F_STRING* allot_string_internal(CELL capacity) +{ + F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); + + string->length = tag_fixnum(capacity); + string->hashcode = F; + string->aux = F; + + return string; +} + +/* allocates memory */ +void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) +{ + if(fill <= 0x7f) + memset((void *)SREF(string,start),fill,capacity - start); + else + { + CELL i; + + for(i = start; i < capacity; i++) + { + REGISTER_UNTAGGED(string); + set_string_nth(string,i,fill); + UNREGISTER_UNTAGGED(string); + } + } +} + +/* untagged */ +F_STRING *allot_string(CELL capacity, CELL fill) +{ + F_STRING* string = allot_string_internal(capacity); + REGISTER_UNTAGGED(string); + fill_string(string,0,capacity,fill); + UNREGISTER_UNTAGGED(string); + return string; +} + +void primitive_string(void) +{ + CELL initial = to_cell(dpop()); + CELL length = unbox_array_size(); + dpush(tag_object(allot_string(length,initial))); +} + +F_STRING* reallot_string(F_STRING* string, CELL capacity) +{ + CELL to_copy = string_capacity(string); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(string); + F_STRING *new_string = allot_string_internal(capacity); + UNREGISTER_UNTAGGED(string); + + memcpy(new_string + 1,string + 1,to_copy); + + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + write_barrier((CELL)new_string); + new_string->aux = tag_object(new_aux); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + fill_string(new_string,to_copy,capacity,'\0'); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + return new_string; +} + +void primitive_resize_string(void) +{ + F_STRING* string = untag_string(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_string(string,capacity))); +} + +/* Some ugly macros to prevent a 2x code duplication */ + +#define MEMORY_TO_STRING(type,utype) \ + F_STRING *memory_to_##type##_string(const type *string, CELL length) \ + { \ + REGISTER_C_STRING(string); \ + F_STRING* s = allot_string_internal(length); \ + UNREGISTER_C_STRING(string); \ + CELL i; \ + for(i = 0; i < length; i++) \ + { \ + REGISTER_UNTAGGED(s); \ + set_string_nth(s,i,(utype)*string); \ + UNREGISTER_UNTAGGED(s); \ + string++; \ + } \ + return s; \ + } \ + F_STRING *from_##type##_string(const type *str) \ + { \ + CELL length = 0; \ + const type *scan = str; \ + while(*scan++) length++; \ + return memory_to_##type##_string(str,length); \ + } \ + void box_##type##_string(const type *str) \ + { \ + dpush(str ? tag_object(from_##type##_string(str)) : F); \ + } + +MEMORY_TO_STRING(char,u8) +MEMORY_TO_STRING(u16,u16) +MEMORY_TO_STRING(u32,u32) + +bool check_string(F_STRING *s, CELL max) +{ + CELL capacity = string_capacity(s); + CELL i; + for(i = 0; i < capacity; i++) + { + CELL ch = string_nth(s,i); + if(ch == '\0' || ch >= (1 << (max * 8))) + return false; + } + return true; +} + +F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) +{ + return allot_byte_array((capacity + 1) * size); +} + +#define STRING_TO_MEMORY(type) \ + void type##_string_to_memory(F_STRING *s, type *string) \ + { \ + CELL i; \ + CELL capacity = string_capacity(s); \ + for(i = 0; i < capacity; i++) \ + string[i] = string_nth(s,i); \ + } \ + void primitive_##type##_string_to_memory(void) \ + { \ + type *address = unbox_alien(); \ + F_STRING *str = untag_string(dpop()); \ + type##_string_to_memory(str,address); \ + } \ + F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \ + { \ + CELL capacity = string_capacity(s); \ + F_BYTE_ARRAY *_c_str; \ + if(check && !check_string(s,sizeof(type))) \ + general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ + REGISTER_UNTAGGED(s); \ + _c_str = allot_c_string(capacity,sizeof(type)); \ + UNREGISTER_UNTAGGED(s); \ + type *c_str = (type*)(_c_str + 1); \ + type##_string_to_memory(s,c_str); \ + c_str[capacity] = 0; \ + return _c_str; \ + } \ + type *to_##type##_string(F_STRING *s, bool check) \ + { \ + return (type*)(string_to_##type##_alien(s,check) + 1); \ + } \ + type *unbox_##type##_string(void) \ + { \ + return to_##type##_string(untag_string(dpop()),true); \ + } + +STRING_TO_MEMORY(char); +STRING_TO_MEMORY(u16); + +void primitive_string_nth(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + dpush(tag_fixnum(string_nth(string,index))); +} + +void primitive_set_string_nth(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth(string,index,value); +} + +void primitive_set_string_nth_fast(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_fast(string,index,value); +} + +void primitive_set_string_nth_slow(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_slow(string,index,value); +} diff --git a/vm/strings.h b/vm/strings.h new file mode 100644 index 0000000000..d16a85ebea --- /dev/null +++ b/vm/strings.h @@ -0,0 +1,50 @@ +INLINE CELL string_capacity(F_STRING* str) +{ + return untag_fixnum_fast(str->length); +} + +INLINE CELL string_size(CELL size) +{ + return sizeof(F_STRING) + size; +} + +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) + +INLINE F_STRING* untag_string(CELL tagged) +{ + type_check(STRING_TYPE,tagged); + return untag_object(tagged); +} + +F_STRING* allot_string_internal(CELL capacity); +F_STRING* allot_string(CELL capacity, CELL fill); +void primitive_string(void); +F_STRING *reallot_string(F_STRING *string, CELL capacity); +void primitive_resize_string(void); + +F_STRING *memory_to_char_string(const char *string, CELL length); +F_STRING *from_char_string(const char *c_string); +DLLEXPORT void box_char_string(const char *c_string); + +F_STRING *memory_to_u16_string(const u16 *string, CELL length); +F_STRING *from_u16_string(const u16 *c_string); +DLLEXPORT void box_u16_string(const u16 *c_string); + +void char_string_to_memory(F_STRING *s, char *string); +F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); +char* to_char_string(F_STRING *s, bool check); +DLLEXPORT char *unbox_char_string(void); + +void u16_string_to_memory(F_STRING *s, u16 *string); +F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); +u16* to_u16_string(F_STRING *s, bool check); +DLLEXPORT u16 *unbox_u16_string(void); + +/* String getters and setters */ +CELL string_nth(F_STRING* string, CELL index); +void set_string_nth(F_STRING* string, CELL index, CELL value); + +void primitive_string_nth(void); +void primitive_set_string_nth_slow(void); +void primitive_set_string_nth_fast(void); diff --git a/vm/tuples.c b/vm/tuples.c new file mode 100644 index 0000000000..0ad7557179 --- /dev/null +++ b/vm/tuples.c @@ -0,0 +1,35 @@ +#include "master.h" + +/* push a new tuple on the stack */ +F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) +{ + REGISTER_UNTAGGED(layout); + F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); + UNREGISTER_UNTAGGED(layout); + tuple->layout = tag_object(layout); + return tuple; +} + +void primitive_tuple(void) +{ + F_TUPLE_LAYOUT *layout = untag_object(dpop()); + F_FIXNUM size = untag_fixnum_fast(layout->size); + + F_TUPLE *tuple = allot_tuple(layout); + F_FIXNUM i; + for(i = size - 1; i >= 0; i--) + put(AREF(tuple,i),F); + + dpush(tag_tuple(tuple)); +} + +/* push a new tuple on the stack, filling its slots from the stack */ +void primitive_tuple_boa(void) +{ + F_TUPLE_LAYOUT *layout = untag_object(dpop()); + F_FIXNUM size = untag_fixnum_fast(layout->size); + F_TUPLE *tuple = allot_tuple(layout); + memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size); + ds -= CELLS * size; + dpush(tag_tuple(tuple)); +} diff --git a/vm/tuples.h b/vm/tuples.h new file mode 100644 index 0000000000..64b62e2539 --- /dev/null +++ b/vm/tuples.h @@ -0,0 +1,25 @@ +INLINE CELL tag_tuple(F_TUPLE *tuple) +{ + return RETAG(tuple,TUPLE_TYPE); +} + +INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) +{ + CELL size = untag_fixnum_fast(layout->size); + return sizeof(F_TUPLE) + size * CELLS; +} + +INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) +{ + return get(AREF(tuple,slot)); +} + +INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) +{ + put(AREF(tuple,slot),value); + write_barrier((CELL)tuple); +} + +void primitive_tuple(void); +void primitive_tuple_boa(void); +void primitive_tuple_layout(void); diff --git a/vm/types.c b/vm/types.c deleted file mode 100755 index b5981dc3b1..0000000000 --- a/vm/types.c +++ /dev/null @@ -1,623 +0,0 @@ -#include "master.h" - -/* FFI calls this */ -void box_boolean(bool value) -{ - dpush(value ? T : F); -} - -/* FFI calls this */ -bool to_boolean(CELL value) -{ - return value != F; -} - -CELL clone_object(CELL object) -{ - CELL size = object_size(object); - if(size == 0) - return object; - else - { - REGISTER_ROOT(object); - void *new_obj = allot_object(type_of(object),size); - UNREGISTER_ROOT(object); - - CELL tag = TAG(object); - memcpy(new_obj,(void*)UNTAG(object),size); - return RETAG(new_obj,tag); - } -} - -void primitive_clone(void) -{ - drepl(clone_object(dpeek())); -} - -F_WORD *allot_word(CELL vocab, CELL name) -{ - REGISTER_ROOT(vocab); - REGISTER_ROOT(name); - F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); - UNREGISTER_ROOT(name); - UNREGISTER_ROOT(vocab); - - word->hashcode = tag_fixnum((rand() << 16) ^ rand()); - word->vocabulary = vocab; - word->name = name; - word->def = userenv[UNDEFINED_ENV]; - word->props = F; - word->counter = tag_fixnum(0); - word->optimizedp = F; - word->subprimitive = F; - word->profiling = NULL; - word->code = NULL; - - REGISTER_UNTAGGED(word); - jit_compile_word(word,word->def,true); - UNREGISTER_UNTAGGED(word); - - REGISTER_UNTAGGED(word); - update_word_xt(word); - UNREGISTER_UNTAGGED(word); - - if(profiling_p) - relocate_code_block(word->profiling); - - return word; -} - -/* ( name vocabulary -- word ) */ -void primitive_word(void) -{ - CELL vocab = dpop(); - CELL name = dpop(); - dpush(tag_object(allot_word(vocab,name))); -} - -/* word-xt ( word -- start end ) */ -void primitive_word_xt(void) -{ - F_WORD *word = untag_word(dpop()); - F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); - dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); - dpush(allot_cell((CELL)code + code->block.size)); -} - -void primitive_wrapper(void) -{ - F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); - wrapper->object = dpeek(); - drepl(tag_object(wrapper)); -} - -/* Arrays */ - -/* the array is full of undefined data, and must be correctly filled before the -next GC. size is in cells */ -F_ARRAY *allot_array_internal(CELL type, CELL capacity) -{ - F_ARRAY *array = allot_object(type,array_size(capacity)); - array->capacity = tag_fixnum(capacity); - return array; -} - -/* make a new array with an initial element */ -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) -{ - int i; - REGISTER_ROOT(fill); - F_ARRAY* array = allot_array_internal(type, capacity); - UNREGISTER_ROOT(fill); - if(fill == 0) - memset((void*)AREF(array,0),'\0',capacity * CELLS); - else - { - /* No need for write barrier here. Either the object is in - the nursery, or it was allocated directly in tenured space - and the write barrier is already hit for us in that case. */ - for(i = 0; i < capacity; i++) - put(AREF(array,i),fill); - } - return array; -} - -/* push a new array on the stack */ -void primitive_array(void) -{ - CELL initial = dpop(); - CELL size = unbox_array_size(); - dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); -} - -CELL allot_array_1(CELL obj) -{ - REGISTER_ROOT(obj); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); - UNREGISTER_ROOT(obj); - set_array_nth(a,0,obj); - return tag_object(a); -} - -CELL allot_array_2(CELL v1, CELL v2) -{ - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - return tag_object(a); -} - -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) -{ - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - REGISTER_ROOT(v3); - REGISTER_ROOT(v4); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4); - UNREGISTER_ROOT(v4); - UNREGISTER_ROOT(v3); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - set_array_nth(a,2,v3); - set_array_nth(a,3,v4); - return tag_object(a); -} - -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); -#endif - - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); - UNREGISTER_UNTAGGED(array); - - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - - return new_array; -} - -void primitive_resize_array(void) -{ - F_ARRAY* array = untag_array(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity))); -} - -void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) -{ - F_ARRAY *underlying = untag_object(array->array); - REGISTER_ROOT(elt); - - if(array->count == array_capacity(underlying)) - { - underlying = reallot_array(underlying,array->count * 2); - array->array = tag_object(underlying); - } - - UNREGISTER_ROOT(elt); - set_array_nth(underlying,array->count++,elt); -} - -void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) -{ - REGISTER_UNTAGGED(elts); - - F_ARRAY *underlying = untag_object(array->array); - - CELL elts_size = array_capacity(elts); - CELL new_size = array->count + elts_size; - - if(new_size >= array_capacity(underlying)) - { - underlying = reallot_array(underlying,new_size * 2); - array->array = tag_object(underlying); - } - - UNREGISTER_UNTAGGED(elts); - - write_barrier(array->array); - - memcpy((void *)AREF(underlying,array->count), - (void *)AREF(elts,0), - elts_size * CELLS); - - array->count += elts_size; -} - -/* Byte arrays */ - -/* must fill out array before next GC */ -F_BYTE_ARRAY *allot_byte_array_internal(CELL size) -{ - F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, - byte_array_size(size)); - array->capacity = tag_fixnum(size); - return array; -} - -/* size is in bytes this time */ -F_BYTE_ARRAY *allot_byte_array(CELL size) -{ - F_BYTE_ARRAY *array = allot_byte_array_internal(size); - memset(array + 1,0,size); - return array; -} - -/* push a new byte array on the stack */ -void primitive_byte_array(void) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array(size))); -} - -void primitive_uninitialized_byte_array(void) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array_internal(size))); -} - -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - assert(untag_header(array->header) == BYTE_ARRAY_TYPE); -#endif - - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); - UNREGISTER_UNTAGGED(array); - - memcpy(new_array + 1,array + 1,to_copy); - - return new_array; -} - -void primitive_resize_byte_array(void) -{ - F_BYTE_ARRAY* array = untag_byte_array(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_byte_array(array,capacity))); -} - -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) -{ - CELL new_size = array->count + len; - F_BYTE_ARRAY *underlying = untag_object(array->array); - - if(new_size >= byte_array_capacity(underlying)) - { - underlying = reallot_byte_array(underlying,new_size * 2); - array->array = tag_object(underlying); - } - - memcpy((void *)BREF(underlying,array->count),elts,len); - - array->count += len; -} - -/* Tuples */ - -/* push a new tuple on the stack */ -F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) -{ - REGISTER_UNTAGGED(layout); - F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); - UNREGISTER_UNTAGGED(layout); - tuple->layout = tag_object(layout); - return tuple; -} - -void primitive_tuple(void) -{ - F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - - F_TUPLE *tuple = allot_tuple(layout); - F_FIXNUM i; - for(i = size - 1; i >= 0; i--) - put(AREF(tuple,i),F); - - dpush(tag_tuple(tuple)); -} - -/* push a new tuple on the stack, filling its slots from the stack */ -void primitive_tuple_boa(void) -{ - F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - F_TUPLE *tuple = allot_tuple(layout); - memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size); - ds -= CELLS * size; - dpush(tag_tuple(tuple)); -} - -/* Strings */ -CELL string_nth(F_STRING* string, CELL index) -{ - /* If high bit is set, the most significant 16 bits of the char - come from the aux vector. The least significant bit of the - corresponding aux vector entry is negated, so that we can - XOR the two components together and get the original code point - back. */ - CELL ch = bget(SREF(string,index)); - if((ch & 0x80) == 0) - return ch; - else - { - F_BYTE_ARRAY *aux = untag_object(string->aux); - return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; - } -} - -void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) -{ - bput(SREF(string,index),ch); -} - -void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) -{ - F_BYTE_ARRAY *aux; - - bput(SREF(string,index),(ch & 0x7f) | 0x80); - - if(string->aux == F) - { - REGISTER_UNTAGGED(string); - /* We don't need to pre-initialize the - byte array with any data, since we - only ever read from the aux vector - if the most significant bit of a - character is set. Initially all of - the bits are clear. */ - aux = allot_byte_array_internal( - untag_fixnum_fast(string->length) - * sizeof(u16)); - UNREGISTER_UNTAGGED(string); - - write_barrier((CELL)string); - string->aux = tag_object(aux); - } - else - aux = untag_object(string->aux); - - cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); -} - -/* allocates memory */ -void set_string_nth(F_STRING* string, CELL index, CELL ch) -{ - if(ch <= 0x7f) - set_string_nth_fast(string,index,ch); - else - set_string_nth_slow(string,index,ch); -} - -/* untagged */ -F_STRING* allot_string_internal(CELL capacity) -{ - F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); - - string->length = tag_fixnum(capacity); - string->hashcode = F; - string->aux = F; - - return string; -} - -/* allocates memory */ -void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) -{ - if(fill <= 0x7f) - memset((void *)SREF(string,start),fill,capacity - start); - else - { - CELL i; - - for(i = start; i < capacity; i++) - { - REGISTER_UNTAGGED(string); - set_string_nth(string,i,fill); - UNREGISTER_UNTAGGED(string); - } - } -} - -/* untagged */ -F_STRING *allot_string(CELL capacity, CELL fill) -{ - F_STRING* string = allot_string_internal(capacity); - REGISTER_UNTAGGED(string); - fill_string(string,0,capacity,fill); - UNREGISTER_UNTAGGED(string); - return string; -} - -void primitive_string(void) -{ - CELL initial = to_cell(dpop()); - CELL length = unbox_array_size(); - dpush(tag_object(allot_string(length,initial))); -} - -F_STRING* reallot_string(F_STRING* string, CELL capacity) -{ - CELL to_copy = string_capacity(string); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(string); - F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_UNTAGGED(string); - - memcpy(new_string + 1,string + 1,to_copy); - - if(string->aux != F) - { - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - write_barrier((CELL)new_string); - new_string->aux = tag_object(new_aux); - - F_BYTE_ARRAY *aux = untag_object(string->aux); - memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); - } - - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,'\0'); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - return new_string; -} - -void primitive_resize_string(void) -{ - F_STRING* string = untag_string(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_string(string,capacity))); -} - -/* Some ugly macros to prevent a 2x code duplication */ - -#define MEMORY_TO_STRING(type,utype) \ - F_STRING *memory_to_##type##_string(const type *string, CELL length) \ - { \ - REGISTER_C_STRING(string); \ - F_STRING* s = allot_string_internal(length); \ - UNREGISTER_C_STRING(string); \ - CELL i; \ - for(i = 0; i < length; i++) \ - { \ - REGISTER_UNTAGGED(s); \ - set_string_nth(s,i,(utype)*string); \ - UNREGISTER_UNTAGGED(s); \ - string++; \ - } \ - return s; \ - } \ - F_STRING *from_##type##_string(const type *str) \ - { \ - CELL length = 0; \ - const type *scan = str; \ - while(*scan++) length++; \ - return memory_to_##type##_string(str,length); \ - } \ - void box_##type##_string(const type *str) \ - { \ - dpush(str ? tag_object(from_##type##_string(str)) : F); \ - } - -MEMORY_TO_STRING(char,u8) -MEMORY_TO_STRING(u16,u16) -MEMORY_TO_STRING(u32,u32) - -bool check_string(F_STRING *s, CELL max) -{ - CELL capacity = string_capacity(s); - CELL i; - for(i = 0; i < capacity; i++) - { - CELL ch = string_nth(s,i); - if(ch == '\0' || ch >= (1 << (max * 8))) - return false; - } - return true; -} - -F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) -{ - return allot_byte_array((capacity + 1) * size); -} - -#define STRING_TO_MEMORY(type) \ - void type##_string_to_memory(F_STRING *s, type *string) \ - { \ - CELL i; \ - CELL capacity = string_capacity(s); \ - for(i = 0; i < capacity; i++) \ - string[i] = string_nth(s,i); \ - } \ - void primitive_##type##_string_to_memory(void) \ - { \ - type *address = unbox_alien(); \ - F_STRING *str = untag_string(dpop()); \ - type##_string_to_memory(str,address); \ - } \ - F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \ - { \ - CELL capacity = string_capacity(s); \ - F_BYTE_ARRAY *_c_str; \ - if(check && !check_string(s,sizeof(type))) \ - general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - REGISTER_UNTAGGED(s); \ - _c_str = allot_c_string(capacity,sizeof(type)); \ - UNREGISTER_UNTAGGED(s); \ - type *c_str = (type*)(_c_str + 1); \ - type##_string_to_memory(s,c_str); \ - c_str[capacity] = 0; \ - return _c_str; \ - } \ - type *to_##type##_string(F_STRING *s, bool check) \ - { \ - return (type*)(string_to_##type##_alien(s,check) + 1); \ - } \ - type *unbox_##type##_string(void) \ - { \ - return to_##type##_string(untag_string(dpop()),true); \ - } - -STRING_TO_MEMORY(char); -STRING_TO_MEMORY(u16); - -void primitive_string_nth(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - dpush(tag_fixnum(string_nth(string,index))); -} - -void primitive_set_string_nth(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth(string,index,value); -} - -void primitive_set_string_nth_fast(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth_fast(string,index,value); -} - -void primitive_set_string_nth_slow(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth_slow(string,index,value); -} diff --git a/vm/types.h b/vm/types.h deleted file mode 100755 index f881261dce..0000000000 --- a/vm/types.h +++ /dev/null @@ -1,231 +0,0 @@ -/* Inline functions */ -INLINE CELL array_size(CELL size) -{ - return sizeof(F_ARRAY) + size * CELLS; -} - -INLINE CELL string_capacity(F_STRING* str) -{ - return untag_fixnum_fast(str->length); -} - -INLINE CELL string_size(CELL size) -{ - return sizeof(F_STRING) + size; -} - -DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) - -INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) -{ - return untag_fixnum_fast(array->capacity); -} - -INLINE CELL byte_array_size(CELL size) -{ - return sizeof(F_BYTE_ARRAY) + size; -} - -INLINE CELL callstack_size(CELL size) -{ - return sizeof(F_CALLSTACK) + size; -} - -DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) - -INLINE CELL tag_boolean(CELL untagged) -{ - return (untagged == false ? F : T); -} - -DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) - -INLINE CELL array_capacity(F_ARRAY* array) -{ -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE); -#endif - return array->capacity >> TAG_BITS; -} - -#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) -#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) - -INLINE CELL array_nth(F_ARRAY *array, CELL slot) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == ARRAY_TYPE); -#endif - return get(AREF(array,slot)); -} - -INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == ARRAY_TYPE); -#endif - put(AREF(array,slot),value); - write_barrier((CELL)array); -} - -#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) - -INLINE F_STRING* untag_string(CELL tagged) -{ - type_check(STRING_TYPE,tagged); - return untag_object(tagged); -} - -DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) - -DEFINE_UNTAG(F_WORD,WORD_TYPE,word) - -INLINE CELL tag_tuple(F_TUPLE *tuple) -{ - return RETAG(tuple,TUPLE_TYPE); -} - -INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) -{ - CELL size = untag_fixnum_fast(layout->size); - return sizeof(F_TUPLE) + size * CELLS; -} - -INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) -{ - return get(AREF(tuple,slot)); -} - -INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) -{ - put(AREF(tuple,slot),value); - write_barrier((CELL)tuple); -} - -/* Prototypes */ -DLLEXPORT void box_boolean(bool value); -DLLEXPORT bool to_boolean(CELL value); - -F_ARRAY *allot_array_internal(CELL type, CELL capacity); -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); -F_BYTE_ARRAY *allot_byte_array(CELL size); - -CELL allot_array_1(CELL obj); -CELL allot_array_2(CELL v1, CELL v2); -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); - -void primitive_array(void); -void primitive_tuple(void); -void primitive_tuple_boa(void); -void primitive_tuple_layout(void); -void primitive_byte_array(void); -void primitive_uninitialized_byte_array(void); -void primitive_clone(void); - -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); -void primitive_resize_array(void); -void primitive_resize_byte_array(void); - -F_STRING* allot_string_internal(CELL capacity); -F_STRING* allot_string(CELL capacity, CELL fill); -void primitive_uninitialized_string(void); -void primitive_string(void); -F_STRING *reallot_string(F_STRING *string, CELL capacity); -void primitive_resize_string(void); - -F_STRING *memory_to_char_string(const char *string, CELL length); -F_STRING *from_char_string(const char *c_string); -DLLEXPORT void box_char_string(const char *c_string); - -F_STRING *memory_to_u16_string(const u16 *string, CELL length); -F_STRING *from_u16_string(const u16 *c_string); -DLLEXPORT void box_u16_string(const u16 *c_string); - -void char_string_to_memory(F_STRING *s, char *string); -F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); -char* to_char_string(F_STRING *s, bool check); -DLLEXPORT char *unbox_char_string(void); - -void u16_string_to_memory(F_STRING *s, u16 *string); -F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); -u16* to_u16_string(F_STRING *s, bool check); -DLLEXPORT u16 *unbox_u16_string(void); - -/* String getters and setters */ -CELL string_nth(F_STRING* string, CELL index); -void set_string_nth(F_STRING* string, CELL index, CELL value); - -void primitive_string_nth(void); -void primitive_set_string_nth_slow(void); -void primitive_set_string_nth_fast(void); - -F_WORD *allot_word(CELL vocab, CELL name); -void primitive_word(void); -void primitive_word_xt(void); - -void primitive_wrapper(void); - -/* Macros to simulate a vector in C */ -typedef struct { - CELL count; - CELL array; -} F_GROWABLE_ARRAY; - -/* Allocates memory */ -INLINE F_GROWABLE_ARRAY make_growable_array(void) -{ - F_GROWABLE_ARRAY result; - result.count = 0; - result.array = tag_object(allot_array(ARRAY_TYPE,100,F)); - return result; -} - -#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ - REGISTER_ROOT(result##_g.array) - -void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); - -#define GROWABLE_ARRAY_ADD(result,elt) \ - growable_array_add(&result##_g,elt) - -void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); - -#define GROWABLE_ARRAY_APPEND(result,elts) \ - growable_array_append(&result##_g,elts) - -INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) -{ - array->array = tag_object(reallot_array(untag_object(array->array),array->count)); -} - -#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) - -#define GROWABLE_ARRAY_DONE(result) \ - UNREGISTER_ROOT(result##_g.array); \ - CELL result = result##_g.array; - -/* Macros to simulate a byte vector in C */ -typedef struct { - CELL count; - CELL array; -} F_GROWABLE_BYTE_ARRAY; - -INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) -{ - F_GROWABLE_BYTE_ARRAY result; - result.count = 0; - result.array = tag_object(allot_byte_array(100)); - return result; -} - -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); - -INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) -{ - byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); -} diff --git a/vm/words.c b/vm/words.c new file mode 100644 index 0000000000..615c11e5af --- /dev/null +++ b/vm/words.c @@ -0,0 +1,82 @@ +#include "master.h" + +F_WORD *allot_word(CELL vocab, CELL name) +{ + REGISTER_ROOT(vocab); + REGISTER_ROOT(name); + F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); + UNREGISTER_ROOT(name); + UNREGISTER_ROOT(vocab); + + word->hashcode = tag_fixnum((rand() << 16) ^ rand()); + word->vocabulary = vocab; + word->name = name; + word->def = userenv[UNDEFINED_ENV]; + word->props = F; + word->counter = tag_fixnum(0); + word->direct_entry_def = F; + word->subprimitive = F; + word->profiling = NULL; + word->code = NULL; + + REGISTER_UNTAGGED(word); + jit_compile_word(word,word->def,true); + UNREGISTER_UNTAGGED(word); + + REGISTER_UNTAGGED(word); + update_word_xt(word); + UNREGISTER_UNTAGGED(word); + + if(profiling_p) + relocate_code_block(word->profiling); + + return word; +} + +/* ( name vocabulary -- word ) */ +void primitive_word(void) +{ + CELL vocab = dpop(); + CELL name = dpop(); + dpush(tag_object(allot_word(vocab,name))); +} + +/* word-xt ( word -- start end ) */ +void primitive_word_xt(void) +{ + F_WORD *word = untag_word(dpop()); + F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); + dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); + dpush(allot_cell((CELL)code + code->block.size)); +} + +/* Allocates memory */ +void update_word_xt(F_WORD *word) +{ + if(profiling_p) + { + if(!word->profiling) + { + REGISTER_UNTAGGED(word); + F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); + UNREGISTER_UNTAGGED(word); + word->profiling = profiling; + } + + word->xt = (XT)(word->profiling + 1); + } + else + word->xt = (XT)(word->code + 1); +} + +void primitive_optimized_p(void) +{ + drepl(tag_boolean(word_optimized_p(untag_word(dpeek())))); +} + +void primitive_wrapper(void) +{ + F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); + wrapper->object = dpeek(); + drepl(tag_object(wrapper)); +} diff --git a/vm/words.h b/vm/words.h new file mode 100644 index 0000000000..aa86c87ae1 --- /dev/null +++ b/vm/words.h @@ -0,0 +1,16 @@ +DEFINE_UNTAG(F_WORD,WORD_TYPE,word) + +F_WORD *allot_word(CELL vocab, CELL name); + +void primitive_word(void); +void primitive_word_xt(void); +void update_word_xt(F_WORD *word); + +INLINE bool word_optimized_p(F_WORD *word) +{ + return word->code->block.type == WORD_TYPE; +} + +void primitive_optimized_p(void); + +void primitive_wrapper(void); From c15a4c1c5a0d49fcbbcc890ff1ce4d0f931cb151 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 17:53:14 -0500 Subject: [PATCH 31/83] Add new relocation type for call sites which may be replaced by ICs --- basis/compiler/codegen/fixup/fixup.factor | 3 ++ basis/compiler/constants/constants.factor | 9 +++--- basis/cpu/ppc/bootstrap.factor | 2 +- basis/cpu/x86/assembler/assembler.factor | 2 +- basis/cpu/x86/bootstrap.factor | 2 +- core/words/words.factor | 1 + vm/code_block.c | 39 +++++++++++++++++++++-- vm/code_block.h | 4 ++- vm/code_heap.c | 3 ++ 9 files changed, 54 insertions(+), 11 deletions(-) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index e22242d48e..45d87b3270 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -58,6 +58,9 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; +: rel-word-direct ( word class -- ) + [ add-literal ] dip rt-xt-direct rel-fixup ; + : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b3757bf008..f7fe430162 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -41,10 +41,11 @@ CONSTANT: rt-primitive 0 CONSTANT: rt-dlsym 1 CONSTANT: rt-dispatch 2 CONSTANT: rt-xt 3 -CONSTANT: rt-here 4 -CONSTANT: rt-this 5 -CONSTANT: rt-immediate 6 -CONSTANT: rt-stack-chain 7 +CONSTANT: rt-xt-direct 4 +CONSTANT: rt-here 5 +CONSTANT: rt-this 6 +CONSTANT: rt-immediate 7 +CONSTANT: rt-stack-chain 8 : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ef88fe79fd..9e49916d81 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -60,7 +60,7 @@ CONSTANT: rs-reg 30 BCTR ] jit-primitive jit-define -[ 0 BL rc-relative-ppc-3 rt-xt jit-rel ] jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define [ 0 B rc-relative-ppc-3 rt-xt ] jit-word-jump jit-define diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 9b34875bc1..728cd04e55 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -316,7 +316,7 @@ M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word ; +M: callable CALL (CALL) rel-word-direct ; M: label CALL (CALL) label-fixup ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 77a34277ab..03a366198e 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -48,7 +48,7 @@ big-endian off ] jit-word-jump jit-define [ - f CALL rc-relative rt-xt jit-rel + f CALL rc-relative rt-xt-direct jit-rel ] jit-word-call jit-define [ diff --git a/core/words/words.factor b/core/words/words.factor index 7ee9a7ca65..1976c1e4cd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -155,6 +155,7 @@ M: word reset-word [ subwords forget-all ] [ reset-word ] [ + f >>direct-entry-def { "methods" "combination" diff --git a/vm/code_block.c b/vm/code_block.c index 391c8cf56e..4ec800c66d 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -24,6 +24,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) { case RT_PRIMITIVE: case RT_XT: + case RT_XT_DIRECT: case RT_IMMEDIATE: case RT_HERE: index++; @@ -153,14 +154,43 @@ void copy_literal_references(F_CODE_BLOCK *compiled) CELL object_xt(CELL obj) { if(type_of(obj) == WORD_TYPE) - return (CELL)untag_word(obj)->xt; + { + F_WORD *word = untag_object(obj); + return (CELL)word->xt; + } else - return (CELL)untag_quotation(obj)->xt; + { + F_QUOTATION *quot = untag_object(obj); + return (CELL)quot->xt; + } +} + +CELL word_direct_xt(CELL obj) +{ +#ifdef FACTOR_DEBUG + type_check(WORD_TYPE,obj); +#endif + F_WORD *word = untag_object(obj); + CELL quot = word->direct_entry_def; + if(quot == F || max_pic_size == 0) + return (CELL)word->xt; + else + { + F_QUOTATION *untagged = untag_object(quot); +#ifdef FACTOR_DEBUG + type_check(QUOTATION_TYPE,quot); +#endif + if(untagged->compiledp == F) + return (CELL)word->xt; + else + return (CELL)untagged->xt; + } } void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) { - if(REL_TYPE(rel) == RT_XT) + F_RELTYPE type = REL_TYPE(rel); + if(type == RT_XT || type == RT_XT_DIRECT) { CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); F_ARRAY *literals = untag_object(compiled->literals); @@ -319,6 +349,9 @@ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) case RT_XT: absolute_value = object_xt(array_nth(literals,index)); break; + case RT_XT_DIRECT: + absolute_value = word_direct_xt(array_nth(literals,index)); + break; case RT_HERE: absolute_value = offset + (short)to_fixnum(array_nth(literals,index)); break; diff --git a/vm/code_block.h b/vm/code_block.h index cb8ebf5e19..b93e0eec75 100644 --- a/vm/code_block.h +++ b/vm/code_block.h @@ -5,8 +5,10 @@ typedef enum { RT_DLSYM, /* a pointer to a compiled word reference */ RT_DISPATCH, - /* a compiled word reference */ + /* a word's general entry point XT */ RT_XT, + /* a word's direct entry point XT */ + RT_XT_DIRECT, /* current offset */ RT_HERE, /* current code block */ diff --git a/vm/code_heap.c b/vm/code_heap.c index f75fcb1ec5..9d36ffb6df 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -22,6 +22,9 @@ void jit_compile_word(F_WORD *word, CELL def, bool relocate) UNREGISTER_ROOT(def); word->code = untag_quotation(def)->code; + + if(word->direct_entry_def != F) + jit_compile(word->direct_entry_def,relocate); } /* Apply a function to every code block */ From 5b53562c7b6c9651e6039c9e9d41e161849321bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 17:56:15 -0500 Subject: [PATCH 32/83] Add better error checking for INSTANCE: and GENERIC#, and remove unnecessary word props when generic word's combination changes --- core/classes/mixin/mixin-tests.factor | 10 ++++++++++ core/classes/mixin/mixin.factor | 4 +++- core/generic/generic.factor | 2 +- core/generic/single/single-tests.factor | 8 +++++++- core/generic/standard/standard.factor | 7 ++++--- 5 files changed, 25 insertions(+), 6 deletions(-) diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index cd11591d6c..f44642fdd5 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -119,3 +119,13 @@ MIXIN: move-instance-declaration-mixin [ ] [ "IN: classes.mixin.tests.a" "move-mixin-test-1" parse-stream drop ] unit-test [ { string } ] [ move-instance-declaration-mixin members ] unit-test + +MIXIN: silly-mixin +SYMBOL: not-a-class + +[ [ \ not-a-class \ silly-mixin add-mixin-instance ] with-compilation-unit ] must-fail + +SYMBOL: not-a-mixin +TUPLE: a-class ; + +[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 4bdb893d9a..6cf95716be 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -50,7 +50,9 @@ TUPLE: check-mixin-class class ; [ [ f ] 2dip "instances" word-prop set-at ] 2bi ; -: add-mixin-instance ( class mixin -- ) +GENERIC# add-mixin-instance 1 ( class mixin -- ) + +M: class add-mixin-instance #! Note: we call update-classes on the new member, not the #! mixin. This ensures that we only have to update the #! methods whose specializer intersects the new member, not diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 965be91642..4b398f6532 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -164,8 +164,8 @@ M: sequence update-methods ( class seq -- ) drop 2dup [ "combination" word-prop ] dip = [ 2drop ] [ { + [ drop reset-generic ] [ "combination" set-word-prop ] - [ drop "methods" word-prop values forget-all ] [ drop H{ } clone "methods" set-word-prop ] [ define-default-method ] } diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index 8245cbe22f..c8cab970fd 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -4,7 +4,7 @@ generic.single strings sequences arrays kernel accessors words specialized-arrays.double byte-arrays bit-arrays parser namespaces make quotations stack-checker vectors growable hashtables sbufs prettyprint byte-vectors bit-vectors specialized-vectors.double -definitions generic sets graphs assocs grouping see ; +definitions generic sets graphs assocs grouping see eval ; GENERIC: lo-tag-test ( obj -- obj' ) @@ -269,3 +269,9 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ t ] [ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and ] unit-test + +[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test +[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test + +[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test +[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index bf8ea8da08..6e2c80a2ce 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions generic generic.single kernel -namespaces words math combinators sequences ; +namespaces words math math.order combinators sequences ; IN: generic.standard TUPLE: standard-combination < single-combination # ; -C: standard-combination +: ( n -- standard-combination ) + dup 0 2 between? [ "Bad dispatch position" throw ] unless + standard-combination boa ; PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; @@ -24,7 +26,6 @@ CONSTANT: simple-combination T{ standard-combination f 0 } { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] } case ; M: standard-combination picker From dfcbd206b65ca6499dcfa4ab4a3ab0b94af09664 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 18:06:10 -0500 Subject: [PATCH 33/83] Fix -pic command line switch, and enable PICs in user-space --- core/generic/single/single.factor | 9 ++++++++- vm/factor.c | 4 ++-- vm/run.h | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 636f55632d..8154942c16 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -245,6 +245,12 @@ M: f compile-engine ; generic-word get "methods" word-prop assoc-size 2 * next-power-of-2 f ; +: define-cold-call ( word -- ) + #! Direct calls to the generic word (not tail calls or indirect calls) + #! will jump to the inline cache entry point instead of the megamorphic + #! dispatch entry point. + dup [ f inline-cache-miss ] curry [ ] like >>direct-entry-def drop ; + M: single-combination perform-combination [ dup build-decision-tree @@ -256,5 +262,6 @@ M: single-combination perform-combination make-empty-cache , [ lookup-method (execute) ] % ] [ ] make define - ] 2bi + ] + [ drop define-cold-call ] 2tri ] with-combination ; \ No newline at end of file diff --git a/vm/factor.c b/vm/factor.c index 1010e923ea..56a72d5c1e 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -26,6 +26,8 @@ void default_parameters(F_PARAMETERS *p) p->tenured_size = 4 * CELLS; #endif + p->max_pic_size = 3; + p->secure_gc = false; p->fep = false; @@ -100,8 +102,6 @@ void init_factor(F_PARAMETERS *p) p->tenured_size <<= 20; p->code_size <<= 20; - p->max_pic_size = 3; - /* Disable GC during init as a sanity check */ gc_off = true; diff --git a/vm/run.h b/vm/run.h index 9a827d00ef..8f7ef73c0d 100755 --- a/vm/run.h +++ b/vm/run.h @@ -61,7 +61,7 @@ typedef enum { JIT_EXECUTE_CALL, /* Used by polymorphic inline cache generation in inline_cache.c */ - PIC_TAG = 53, + PIC_TAG = 48, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE, From dbc1a8e1a3e0a10b914fecff1c383e78b52e7913 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 18:17:28 -0500 Subject: [PATCH 34/83] Only generate cold call entry points for standard generics and not hooks --- core/generic/single/single.factor | 9 +++++---- core/generic/standard/standard.factor | 9 ++++++++- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8154942c16..9d958b36f3 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -245,11 +245,12 @@ M: f compile-engine ; generic-word get "methods" word-prop assoc-size 2 * next-power-of-2 f ; +HOOK: cold-call-def combination ( word -- quot/f ) + +M: single-combination cold-call-def drop f ; + : define-cold-call ( word -- ) - #! Direct calls to the generic word (not tail calls or indirect calls) - #! will jump to the inline cache entry point instead of the megamorphic - #! dispatch entry point. - dup [ f inline-cache-miss ] curry [ ] like >>direct-entry-def drop ; + dup cold-call-def >>direct-entry-def drop ; M: single-combination perform-combination [ diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 6e2c80a2ce..499495cdc0 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions generic generic.single kernel -namespaces words math math.order combinators sequences ; +namespaces words math math.order combinators sequences +generic.single.private ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -37,6 +38,12 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; +M: standard-combination cold-call-def + #! Direct calls to the generic word (not tail calls or indirect calls) + #! will jump to the inline cache entry point instead of the megamorphic + #! dispatch entry point. + [ f inline-cache-miss ] curry picker prepend ; + M: standard-generic definer drop \ GENERIC# f ; M: simple-generic definer drop \ GENERIC: f ; From 7f766ab355e1ab7d1d568f463c291a68acfbf8b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 21:43:30 -0500 Subject: [PATCH 35/83] Update compiler tests for tag number changes --- .../cfg/value-numbering/value-numbering-tests.factor | 8 ++++---- basis/compiler/tests/codegen.factor | 4 ++-- basis/compiler/tests/float.factor | 2 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/peg-regression.factor | 2 +- basis/compiler/tests/spilling.factor | 2 +- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index ac9603522e..abd2720817 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -92,7 +92,7 @@ sequences ; T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } T{ ##replace f V int-regs 6 D 0 } } value-numbering trim-temps ] unit-test @@ -110,7 +110,7 @@ sequences ; T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } T{ ##replace f V int-regs 6 D 0 } } value-numbering trim-temps ] unit-test @@ -132,7 +132,7 @@ sequences ; T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } + T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } T{ ##replace f V int-regs 14 D 0 } } value-numbering trim-temps ] unit-test @@ -149,6 +149,6 @@ sequences ; T{ ##peek f V int-regs 29 D -1 } T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-imm-branch f V int-regs 33 7 cc/= } + T{ ##compare-imm-branch f V int-regs 33 5 cc/= } } value-numbering trim-temps ] unit-test diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 611371a457..e45246fc17 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -26,7 +26,7 @@ IN: compiler.tests.codegen [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test -[ { 1 2 3 } { 1 4 3 } 3 3 ] +[ { 1 2 3 } { 1 4 3 } 6 6 ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] unit-test @@ -37,7 +37,7 @@ unit-test : foo ( -- ) ; -[ 5 5 ] +[ 3 3 ] [ 1.2 [ tag [ foo ] keep ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 1a604dbd8e..7074b73845 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -9,7 +9,7 @@ math.private tools.test math.floats.private ; [ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test -[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test +[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index af0f029800..d051031d4a 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -10,7 +10,7 @@ IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz optimized? ] unit-test +[ t ] [ M\ array xyz optimized? ] unit-test ! Test predicate inlining : pred-test-1 ( a -- b c ) diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index da2f3fa604..95d454fed1 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -4,7 +4,7 @@ ! optimization, which would batch generic word updates at the ! end of a compilation unit. -USING: kernel accessors peg.ebnf ; +USING: kernel accessors peg.ebnf words ; IN: compiler.tests.peg-regression TUPLE: pipeline-expr background ; diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index b0039132a0..e518ff8df2 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,5 +1,5 @@ USING: math.private kernel combinators accessors arrays -generalizations tools.test ; +generalizations tools.test words ; IN: compiler.tests.spilling : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) From 8c25569e9e04d46468938a8f0f3fb63683dd4721 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 22:45:19 -0500 Subject: [PATCH 36/83] tools.time: print method dispatch statistics --- basis/tools/time/time.factor | 44 +++++++++++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 6 deletions(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 0d1d9f6fa1..269581730b 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,17 +1,19 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.vectors memory io io.styles prettyprint -namespaces system sequences splitting grouping assocs strings ; +namespaces system sequences splitting grouping assocs strings +generic.single combinators ; IN: tools.time : benchmark ( quot -- runtime ) micros [ call micros ] dip - ; inline -: time. ( data -- ) - unclip - "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl +: time. ( time -- ) + "== Running time ==" print nl 1000000 /f pprint " seconds" write ; + +: gc-stats. ( stats -- ) 5 cut* - "==== GARBAGE COLLECTION" print nl + "== Garbage collection ==" print nl [ 6 group { @@ -37,5 +39,35 @@ IN: tools.time } swap zip simple-table. ] bi* ; +: dispatch-stats. ( stats -- ) + "== Megamorphic caches ==" print nl + { "Hits" "Misses" } swap zip simple-table. ; + +: inline-cache-stats. ( stats -- ) + nl "== Polymorphic inline caches ==" print nl + 3 cut + [ + "Transitions:" print + { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip + simple-table. nl + ] [ + "Type check stubs:" print + { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip + simple-table. + ] bi* ; + : time ( quot -- ) - gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline + gc-reset + reset-dispatch-stats + reset-inline-cache-stats + benchmark gc-stats dispatch-stats inline-cache-stats + H{ { table-gap { 20 20 } } } [ + [ + [ [ time. ] 3dip ] with-cell + [ ] with-cell + ] with-row + [ + [ [ gc-stats. ] 2dip ] with-cell + [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell + ] with-row + ] tabular-output nl ; inline From 2d0925d995a2234e191a605a9b625e287b628002 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 28 Apr 2009 22:51:35 -0500 Subject: [PATCH 37/83] add make-hard-link to io.files.links --- basis/io/files/links/links-docs.factor | 4 ++++ basis/io/files/links/links.factor | 2 ++ basis/io/files/links/unix/unix.factor | 3 +++ basis/unix/unix.factor | 1 + 4 files changed, 10 insertions(+) diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor index 8419399c92..bf1bedaa08 100644 --- a/basis/io/files/links/links-docs.factor +++ b/basis/io/files/links/links-docs.factor @@ -5,6 +5,10 @@ HELP: make-link { $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } { $description "Creates a symbolic link." } ; +HELP: make-hard-link +{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } } +{ $description "Creates a hard link." } ; + HELP: read-link { $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } { $description "Reads the symbolic link and returns its target path." } ; diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor index 1212d579db..7aec916c72 100644 --- a/basis/io/files/links/links.factor +++ b/basis/io/files/links/links.factor @@ -6,6 +6,8 @@ IN: io.files.links HOOK: make-link os ( target symlink -- ) +HOOK: make-hard-link os ( target link -- ) + HOOK: read-link os ( symlink -- path ) : copy-link ( target symlink -- ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 7d2a6ee4f3..c9a651b484 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -7,6 +7,9 @@ IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; +M: unix make-hard-link ( path1 path2 -- ) + normalize-path link io-error ; + M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index a6a0147504..10fb2ad64f 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -194,6 +194,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; +FUNCTION: int link ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; FUNCTION: int unlink ( char* path ) ; From 924331648967d883f7b903a67a7d86d2aa55fa19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 23:05:18 -0500 Subject: [PATCH 38/83] Debugging inline caching --- basis/bootstrap/image/image.factor | 2 +- basis/cpu/x86/bootstrap.factor | 35 +++++++++++++++++------------- vm/code_block.c | 15 ++++++++++++- vm/code_block.h | 2 ++ vm/code_gc.c | 3 +++ vm/code_heap.c | 2 +- vm/code_heap.h | 7 ++++++ vm/cpu-x86.32.S | 2 +- vm/cpu-x86.h | 2 +- vm/data_gc.c | 2 +- vm/inline_cache.c | 14 ++++++++++-- 11 files changed, 63 insertions(+), 23 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index f2dd6e07fd..9c5d0d1532 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -347,7 +347,7 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ drop f , ] + [ direct-entry-def>> , ] ! direct-entry-def [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 03a366198e..0e05c23a2d 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -175,48 +175,53 @@ big-endian off ! The 'make' trick lets us compute the jump distance for the conditional branches there ! Tag -[ +: make-pic-tag ( -- ) ds-reg bootstrap-cell SUB - temp0 tag-bits get AND -] pic-tag jit-define + temp1 temp0 MOV + temp1 tag-mask get AND + temp1 tag-bits get SHL ; + +[ make-pic-tag ] pic-tag jit-define ! Hi-tag [ - ds-reg bootstrap-cell SUB - temp0 object tag-number TEST - [ temp0 temp0 object tag-number neg [+] MOV ] { } make + make-pic-tag + temp1 object tag-number tag-fixnum CMP + [ temp1 temp0 object tag-number neg [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-hi-tag jit-define ! Tuple [ - ds-reg bootstrap-cell SUB - temp0 tuple tag-number TEST - [ temp0 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make + make-pic-tag + temp1 tuple tag-number tag-fixnum CMP + [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-tuple jit-define ! Hi-tag and tuple [ - ds-reg bootstrap-cell SUB + make-pic-tag ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) - temp0 6 TEST + temp1 BIN: 110 tag-fixnum CMP [ - temp1 temp0 MOV ! Make temp0 untagged temp0 tag-mask get bitnot AND ! Set temp1 to 0 for objects, and 4 or 8 for tuples - temp1 1 AND + temp1 1 tag-fixnum AND bootstrap-cell { { 4 [ temp1 2 SHL ] } { 8 [ temp1 3 SHL ] } } case ! Load header cell or tuple layout cell - temp0 temp0 temp1 [+] MOV + temp1 temp0 temp1 [+] MOV ] [ ] make [ length JNE ] [ % ] bi ] pic-hi-tag-tuple jit-define -[ temp0 HEX: ffffffff CMP ] pic-check jit-define +[ + temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel + temp1 temp2 CMP +] pic-check jit-define [ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define diff --git a/vm/code_block.c b/vm/code_block.c index 4ec800c66d..a6d3f9590c 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -194,7 +194,14 @@ void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) { CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); F_ARRAY *literals = untag_object(compiled->literals); - CELL xt = object_xt(array_nth(literals,index)); + CELL obj = array_nth(literals,index); + + CELL xt; + if(type == RT_XT) + xt = object_xt(obj); + else + xt = word_direct_xt(obj); + store_address_in_code_block(REL_CLASS(rel),offset,xt); } } @@ -214,6 +221,12 @@ void update_word_references(F_CODE_BLOCK *compiled) } } +void update_literal_and_word_references(F_CODE_BLOCK *compiled) +{ + update_literal_references(compiled); + update_word_references(compiled); +} + INLINE void check_code_address(CELL address) { #ifdef FACTOR_DEBUG diff --git a/vm/code_block.h b/vm/code_block.h index b93e0eec75..9db9d32499 100644 --- a/vm/code_block.h +++ b/vm/code_block.h @@ -67,6 +67,8 @@ void copy_literal_references(F_CODE_BLOCK *compiled); void update_word_references(F_CODE_BLOCK *compiled); +void update_literal_and_word_references(F_CODE_BLOCK *compiled); + void mark_code_block(F_CODE_BLOCK *compiled); void mark_active_blocks(F_CONTEXT *stacks); diff --git a/vm/code_gc.c b/vm/code_gc.c index 1405daa93f..e72c159375 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -212,6 +212,9 @@ void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) switch(scan->status) { case B_ALLOCATED: + if(secure_gc) + memset(scan + 1,0,scan->size - sizeof(F_BLOCK)); + if(prev && prev->status == B_FREE) prev->size += scan->size; else diff --git a/vm/code_heap.c b/vm/code_heap.c index 9d36ffb6df..0ae3d6b3fa 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -51,7 +51,7 @@ void copy_code_heap_roots(void) collections, done at the end. */ void update_code_heap_roots(void) { - iterate_code_heap(update_literal_references); + iterate_code_heap(update_literal_and_word_references); } /* Update pointers to words referenced from all code blocks. Only after diff --git a/vm/code_heap.h b/vm/code_heap.h index c0d44e8558..b5e176d40c 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -20,3 +20,10 @@ void primitive_modify_code_heap(void); void primitive_code_room(void); void compact_code_heap(void); + +INLINE void check_code_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); +#endif +} diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 2b4a736228..cfac257ff3 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -66,7 +66,7 @@ DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): push %eax call MANGLE(inline_cache_miss) add $12,%esp - jmp *WORD_XT_OFFSET(%eax) + jmp *%eax #include "cpu-x86.S" diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index d84a480b08..9336b39de5 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -20,5 +20,5 @@ INLINE void set_call_site(CELL return_address, CELL target) #ifdef FACTOR_DEBUG assert(*(unsigned char *)(return_address - 5) == 0xe8); #endif - *(F_FIXNUM *)(return_address - 4) = (target - (return_address - 4)); + *(F_FIXNUM *)(return_address - 4) = (target - return_address); } diff --git a/vm/data_gc.c b/vm/data_gc.c index 91bb9ab857..1662fc9a4d 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -507,7 +507,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references); + free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references); else copy_code_heap_roots(); diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 694194c6f3..86322e026d 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -54,6 +54,12 @@ static void update_pic_count(CELL type) cache_entries: array of class/method pairs */ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL cache_entries) { +#ifdef FACTOR_DEBUG + type_check(WORD_TYPE,picker); + type_check(WORD_TYPE,generic_word); + type_check(ARRAY_TYPE,cache_entries); +#endif + REGISTER_ROOT(picker); REGISTER_ROOT(generic_word); REGISTER_ROOT(cache_entries); @@ -94,6 +100,8 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL c jit_word_jump(&jit,userenv[PIC_MISS_WORD]); F_CODE_BLOCK *code = jit_make_code_block(&jit); + relocate_code_block(code); + jit_dispose(&jit); UNREGISTER_ROOT(cache_entries); @@ -137,7 +145,7 @@ static void examine_generic_word(CELL generic_word, CELL *picker, CELL *all_meth static CELL inline_cache_size(CELL cache_entries) { - return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries))); + return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2); } /* Allocates memory */ @@ -170,6 +178,8 @@ static void update_pic_transitions(CELL pic_size) Called from assembly with the actual return address */ XT inline_cache_miss(CELL return_address) { + check_code_pointer(return_address); + CELL cache_entries = dpop(); CELL generic_word = dpop(); CELL object = dpop(); @@ -195,7 +205,7 @@ XT inline_cache_miss(CELL return_address) CELL class = object_class(object); CELL method = lookup_method(object,all_methods); - cache_entries = add_inline_cache_entry(cache_entries,class,method); + cache_entries = add_inline_cache_entry(cache_entries,class,method); block = compile_inline_cache(picker,generic_word,cache_entries); UNREGISTER_ROOT(all_methods); From a26947ba2e6b972a0c3545304931844b3d6b59b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 23:05:42 -0500 Subject: [PATCH 39/83] Remove obsolete -mtune=pentium4 compile flag --- vm/Config.x86.32 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.x86.32 b/vm/Config.x86.32 index bbd26e8e11..e060ef7019 100644 --- a/vm/Config.x86.32 +++ b/vm/Config.x86.32 @@ -2,4 +2,4 @@ BOOT_ARCH = x86 PLAF_DLL_OBJS += vm/cpu-x86.32.o # gcc bug workaround -CFLAGS += -fno-builtin-strlen -fno-builtin-strcat -mtune=pentium4 +CFLAGS += -fno-builtin-strlen -fno-builtin-strcat From 38a38a57a9922348dbc2ed36f210a951a897f388 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 03:00:09 -0500 Subject: [PATCH 40/83] Fix hi-tag-or-tuple PICs --- basis/cpu/x86/bootstrap.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 0e05c23a2d..814cb9416b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -210,12 +210,12 @@ big-endian off ! Set temp1 to 0 for objects, and 4 or 8 for tuples temp1 1 tag-fixnum AND bootstrap-cell { - { 4 [ temp1 2 SHL ] } - { 8 [ temp1 3 SHL ] } + { 4 [ temp1 1 SHR ] } + { 8 [ ] } } case ! Load header cell or tuple layout cell temp1 temp0 temp1 [+] MOV - ] [ ] make [ length JNE ] [ % ] bi + ] [ ] make [ length JL ] [ % ] bi ] pic-hi-tag-tuple jit-define [ From cdcaba75da768595c3913cf3e8c25c974c314837 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 29 Apr 2009 11:10:58 -0500 Subject: [PATCH 41/83] support hard links in tar --- extra/tar/tar.factor | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 297157c08b..e281871252 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -13,7 +13,7 @@ CONSTANT: block-size 512 TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; -ERROR: checksum-error ; +ERROR: checksum-error header ; : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; @@ -60,14 +60,16 @@ ERROR: checksum-error ; ] if ; : parse-tar-header ( seq -- obj ) - [ checksum-header ] keep over zero-checksum = [ + dup checksum-header dup zero-checksum = [ 2drop \ tar-header new 0 >>size 0 >>checksum ] [ - binary [ read-tar-header ] with-byte-reader - [ checksum>> = [ checksum-error ] unless ] keep + [ + binary [ read-tar-header ] with-byte-reader + dup checksum>> + ] dip = [ checksum-error ] unless ] if ; ERROR: unknown-typeflag ch ; @@ -90,7 +92,8 @@ M: unknown-typeflag summary ( obj -- str ) ] if ; ! Hard link -: typeflag-1 ( header -- ) unknown-typeflag ; +: typeflag-1 ( header -- ) + [ name>> ] [ linkname>> ] bi make-hard-link ; ! Symlink : typeflag-2 ( header -- ) @@ -141,7 +144,8 @@ M: unknown-typeflag summary ( obj -- str ) ! Long file name : typeflag-L ( header -- ) - drop ; + drop + ; ! [ read-data-blocks ] keep ! >string [ zero? ] trim-tail filename set ! filename get prepend-current-directory make-directories ; @@ -161,7 +165,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Vendor extended header type : typeflag-X ( header -- ) unknown-typeflag ; -: (parse-tar) ( -- ) +: parse-tar ( -- ) block-size read dup length block-size = [ parse-tar-header dup typeflag>> @@ -182,19 +186,19 @@ M: unknown-typeflag summary ( obj -- str ) ! { CHAR: E [ typeflag-E ] } ! { CHAR: I [ typeflag-I ] } ! { CHAR: K [ typeflag-K ] } - ! { CHAR: L [ typeflag-L ] } + { CHAR: L [ typeflag-L ] } ! { CHAR: M [ typeflag-M ] } ! { CHAR: N [ typeflag-N ] } ! { CHAR: S [ typeflag-S ] } ! { CHAR: V [ typeflag-V ] } ! { CHAR: X [ typeflag-X ] } { f [ drop ] } - } case (parse-tar) + } case parse-tar ] [ drop ] if ; : untar ( path -- ) - normalize-path [ ] [ parent-directory ] bi [ - binary [ (parse-tar) ] with-file-reader + normalize-path dup parent-directory [ + binary [ parse-tar ] with-file-reader ] with-directory ; From 939c2fa64e19fc403bed0fd08db096cbc15f3f56 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 29 Apr 2009 18:22:54 -0500 Subject: [PATCH 42/83] scaffold-emacs should use application-data directory on windows --- basis/tools/scaffold/scaffold.factor | 12 +++++++++--- basis/tools/scaffold/windows/authors.txt | 1 + basis/tools/scaffold/windows/windows.factor | 7 +++++++ 3 files changed, 17 insertions(+), 3 deletions(-) create mode 100755 basis/tools/scaffold/windows/authors.txt create mode 100755 basis/tools/scaffold/windows/windows.factor diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index f35da24266..5034207c98 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -298,9 +298,12 @@ SYMBOL: examples-flag "}" print ] with-variable ; +: touch. ( path -- ) + [ touch-file ] + [ "Click to edit: " write . ] bi ; + : scaffold-rc ( path -- ) - [ home ] dip append-path - [ touch-file ] [ "Click to edit: " write . ] bi ; + [ home ] dip append-path touch. ; : scaffold-factor-boot-rc ( -- ) os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; @@ -308,4 +311,7 @@ SYMBOL: examples-flag : scaffold-factor-rc ( -- ) os windows? "factor-rc" ".factor-rc" ? scaffold-rc ; -: scaffold-emacs ( -- ) ".emacs" scaffold-rc ; + +HOOK: scaffold-emacs os ( -- ) + +M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ; diff --git a/basis/tools/scaffold/windows/authors.txt b/basis/tools/scaffold/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/scaffold/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/tools/scaffold/windows/windows.factor b/basis/tools/scaffold/windows/windows.factor new file mode 100755 index 0000000000..fef6121717 --- /dev/null +++ b/basis/tools/scaffold/windows/windows.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.pathnames system tools.scaffold windows.shell32 ; +IN: tools.scaffold.windows + +M: windows scaffold-emacs ( -- ) + application-data ".emacs" append-path touch. ; From 7fe22b14f86178d57e583bc19bd4fbf94f60aa5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 29 Apr 2009 19:06:06 -0500 Subject: [PATCH 43/83] don't scaffold an authors file if the developer-name is not set --- basis/tools/scaffold/scaffold.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 5034207c98..63dc951d60 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -6,7 +6,7 @@ vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls splitting ascii combinators.short-circuit alarms words.symbol -system ; +system summary ; IN: tools.scaffold SYMBOL: developer-name @@ -16,6 +16,10 @@ ERROR: not-a-vocab-root string ; ERROR: vocab-name-contains-separator path ; ERROR: vocab-name-contains-dot path ; ERROR: no-vocab vocab ; +ERROR: bad-developer-name name ; + +M: bad-developer-name summary + drop "Developer name must be a string." ; path scaffolding? [ - [ developer-name get ] dip utf8 set-file-contents + developer-name get [ + dup string? [ bad-developer-name ] unless + "authors.txt" vocab-root/vocab/file>path scaffolding? [ + utf8 set-file-contents + ] [ + 2drop + ] if ] [ - drop - ] if ; + 2drop + ] if* ; : lookup-type ( string -- object/string ? ) "new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail From deaea55d8571302b767cf4145a1fb59a5ff8505a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 19:39:04 -0500 Subject: [PATCH 44/83] compiler: don't wrap non-inference errors in compile errors, since they indicate compiler bugs; just rethrow them. Add unit test for a PIC regression --- basis/compiler/compiler.factor | 26 ++++++++++++++--------- basis/compiler/tests/pic-problem-1.factor | 14 ++++++++++++ 2 files changed, 30 insertions(+), 10 deletions(-) create mode 100644 basis/compiler/tests/pic-problem-1.factor diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 6783b728e4..cc9899878a 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -89,21 +89,27 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; +: ignore-error ( word error -- * ) + drop + [ clear-compiler-error ] + [ dup def>> deoptimize-with ] + bi ; + +: remember-error ( word error -- * ) + [ swap compiler-error ] + [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] + 2bi ; + : deoptimize ( word error -- * ) #! If the error is ignorable, compile the word with the #! non-optimizing compiler, using its definition. Otherwise, #! if the compiler error is not ignorable, use a dummy #! definition from 'not-compiled-def' which throws an error. - 2dup ignore-error? [ - drop - [ dup def>> deoptimize-with ] - [ clear-compiler-error ] - bi - ] [ - [ swap compiler-error ] - [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] - 2bi - ] if ; + { + { [ dup inference-error? not ] [ rethrow ] } + { [ 2dup ignore-error? ] [ ignore-error ] } + [ remember-error ] + } cond ; : optimize? ( word -- ? ) { diff --git a/basis/compiler/tests/pic-problem-1.factor b/basis/compiler/tests/pic-problem-1.factor new file mode 100644 index 0000000000..4adf0b36b9 --- /dev/null +++ b/basis/compiler/tests/pic-problem-1.factor @@ -0,0 +1,14 @@ +IN: compiler.tests.pic-problem-1 +USING: kernel sequences prettyprint memory tools.test ; + +TUPLE: x ; + +M: x length drop 0 ; + +INSTANCE: x sequence + +<< gc >> + +CONSTANT: blah T{ x } + +[ T{ x } ] [ blah ] unit-test \ No newline at end of file From 02bd4f3f0012abf44538241eaf89280365601f4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 19:39:43 -0500 Subject: [PATCH 45/83] PICs now pass the method table around instead of extracting it from the generic word body. This gels better with how compilation units are supposed to work --- core/generic/single/single.factor | 28 +++++++++--------- core/generic/standard/standard.factor | 4 +-- vm/inline_cache.c | 41 +++++++-------------------- 3 files changed, 26 insertions(+), 47 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 9d958b36f3..8e60b75bdc 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -230,30 +230,28 @@ M: word compile-engine ; M: f compile-engine ; : build-decision-tree ( generic -- methods ) - { - [ generic-word set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop clone - [ find-default default set ] - [ compile-engine ] bi - ] - } cleave ; + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] tri ; : make-empty-cache ( -- array ) generic-word get "methods" word-prop assoc-size 2 * next-power-of-2 f ; -HOOK: cold-call-def combination ( word -- quot/f ) +HOOK: direct-entry-def combination ( word methods -- quot/f ) -M: single-combination cold-call-def drop f ; +M: single-combination direct-entry-def 2drop f ; -: define-cold-call ( word -- ) - dup cold-call-def >>direct-entry-def drop ; +: define-direct-entry ( word methods -- ) + [ drop ] [ direct-entry-def ] 2bi >>direct-entry-def drop ; M: single-combination perform-combination [ + dup generic-word set dup build-decision-tree [ "decision-tree" set-word-prop ] [ @@ -264,5 +262,5 @@ M: single-combination perform-combination [ lookup-method (execute) ] % ] [ ] make define ] - [ drop define-cold-call ] 2tri + [ define-direct-entry ] 2tri ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 499495cdc0..ef3806ca3a 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -38,11 +38,11 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; -M: standard-combination cold-call-def +M: standard-combination direct-entry-def ( word methods -- ) #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - [ f inline-cache-miss ] curry picker prepend ; + picker first [ [ f inline-cache-miss ] 3curry ] keep prefix ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 86322e026d..7230d45dc3 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -52,7 +52,7 @@ static void update_pic_count(CELL type) /* picker: one of dup, over, pick cache_entries: array of class/method pairs */ -static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL cache_entries) +static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL methods, CELL cache_entries) { #ifdef FACTOR_DEBUG type_check(WORD_TYPE,picker); @@ -62,6 +62,7 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL c REGISTER_ROOT(picker); REGISTER_ROOT(generic_word); + REGISTER_ROOT(methods); REGISTER_ROOT(cache_entries); CELL inline_cache_type = determine_inline_cache_type(cache_entries); @@ -96,6 +97,8 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL c object being dispatched on can be popped from the top of the stack. */ jit_emit_subprimitive(&jit,untag_object(picker)); jit_push(&jit,generic_word); + jit_push(&jit,methods); + jit_push(&jit,picker); jit_push(&jit,cache_entries); jit_word_jump(&jit,userenv[PIC_MISS_WORD]); @@ -105,6 +108,7 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL c jit_dispose(&jit); UNREGISTER_ROOT(cache_entries); + UNREGISTER_ROOT(methods); UNREGISTER_ROOT(generic_word); UNREGISTER_ROOT(picker); @@ -121,28 +125,6 @@ static F_CODE_BLOCK *megamorphic_call_stub(CELL generic_word) return untag_quotation(word->def)->code; } -/* Assumes that generic word definitions look like: - [ lookup-method (execute) ] -*/ -static void examine_generic_word(CELL generic_word, CELL *picker, CELL *all_methods) -{ - CELL def = untag_word(generic_word)->def; - F_QUOTATION *quot = untag_quotation(def); - F_ARRAY *array = untag_object(quot->array); - -#ifdef FACTOR_DEBUG - assert(array_capacity(array) == 5); - type_check(WORD_TYPE,array_nth(array,0)); - type_check(ARRAY_TYPE,array_nth(array,1)); - type_check(ARRAY_TYPE,array_nth(array,2)); - type_check(WORD_TYPE,array_nth(array,3)); - type_check(WORD_TYPE,array_nth(array,4)); -#endif - - *picker = array_nth(array,0); - *all_methods = array_nth(array,1); -} - static CELL inline_cache_size(CELL cache_entries) { return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2); @@ -181,6 +163,8 @@ XT inline_cache_miss(CELL return_address) check_code_pointer(return_address); CELL cache_entries = dpop(); + CELL picker = dpop(); + CELL methods = dpop(); CELL generic_word = dpop(); CELL object = dpop(); @@ -194,21 +178,18 @@ XT inline_cache_miss(CELL return_address) block = megamorphic_call_stub(generic_word); else { - CELL picker, all_methods; - examine_generic_word(generic_word,&picker,&all_methods); - REGISTER_ROOT(generic_word); REGISTER_ROOT(cache_entries); REGISTER_ROOT(picker); - REGISTER_ROOT(all_methods); + REGISTER_ROOT(methods); CELL class = object_class(object); - CELL method = lookup_method(object,all_methods); + CELL method = lookup_method(object,methods); cache_entries = add_inline_cache_entry(cache_entries,class,method); - block = compile_inline_cache(picker,generic_word,cache_entries); + block = compile_inline_cache(picker,generic_word,methods,cache_entries); - UNREGISTER_ROOT(all_methods); + UNREGISTER_ROOT(methods); UNREGISTER_ROOT(picker); UNREGISTER_ROOT(cache_entries); UNREGISTER_ROOT(generic_word); From afa787989aebc391e0047936180a58057226b0cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 29 Apr 2009 19:41:22 -0500 Subject: [PATCH 46/83] fix bug in tools.scaffold --- basis/tools/scaffold/scaffold.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 63dc951d60..5c8b868483 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -106,15 +106,14 @@ M: bad-developer-name summary : scaffold-authors ( vocab-root vocab -- ) developer-name get [ - dup string? [ bad-developer-name ] unless "authors.txt" vocab-root/vocab/file>path scaffolding? [ - utf8 set-file-contents + developer-name get swap utf8 set-file-contents ] [ - 2drop + drop ] if ] [ 2drop - ] if* ; + ] if ; : lookup-type ( string -- object/string ? ) "new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail From ae22b345ec961106e3d9ded648f38f8c781ed90c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 19:50:50 -0500 Subject: [PATCH 47/83] PIC -> megamorphic transition now has correct semantics within compilation units --- vm/inline_cache.c | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 7230d45dc3..183f25168e 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -116,13 +116,9 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL m } /* A generic word's definition performs general method lookup. Allocates memory */ -static F_CODE_BLOCK *megamorphic_call_stub(CELL generic_word) +static XT megamorphic_call_stub(CELL generic_word) { - F_WORD *word = untag_word(generic_word); - REGISTER_UNTAGGED(word); - jit_compile(word->def,true); - UNREGISTER_UNTAGGED(word); - return untag_quotation(word->def)->code; + return untag_word(generic_word)->xt; } static CELL inline_cache_size(CELL cache_entries) @@ -168,14 +164,14 @@ XT inline_cache_miss(CELL return_address) CELL generic_word = dpop(); CELL object = dpop(); - F_CODE_BLOCK *block; + XT xt; CELL pic_size = inline_cache_size(cache_entries); update_pic_transitions(pic_size); if(pic_size >= max_pic_size) - block = megamorphic_call_stub(generic_word); + xt = megamorphic_call_stub(generic_word); else { REGISTER_ROOT(generic_word); @@ -187,7 +183,7 @@ XT inline_cache_miss(CELL return_address) CELL method = lookup_method(object,methods); cache_entries = add_inline_cache_entry(cache_entries,class,method); - block = compile_inline_cache(picker,generic_word,methods,cache_entries); + xt = compile_inline_cache(picker,generic_word,methods,cache_entries) + 1; UNREGISTER_ROOT(methods); UNREGISTER_ROOT(picker); @@ -196,7 +192,6 @@ XT inline_cache_miss(CELL return_address) } /* Install the new stub. */ - XT xt = (block + 1); set_call_site(return_address,(CELL)xt); return xt; From bd186b63206f0791078c102749eefc27f06298e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 21:32:05 -0500 Subject: [PATCH 48/83] Eliminate 3 instructions from PIC fast path --- basis/bootstrap/image/image.factor | 17 ++++++++++------- basis/compiler/constants/constants.factor | 1 + basis/cpu/x86/bootstrap.factor | 8 ++++++-- core/generic/standard/standard.factor | 3 ++- vm/code_block.c | 4 ++++ vm/code_block.h | 4 +++- vm/inline_cache.c | 23 ++++++++--------------- vm/run.h | 3 ++- 8 files changed, 36 insertions(+), 27 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9c5d0d1532..05be047328 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -163,6 +163,7 @@ SYMBOL: jit-declare-word SYMBOL: jit-save-stack ! PIC stubs +SYMBOL: pic-load SYMBOL: pic-tag SYMBOL: pic-hi-tag SYMBOL: pic-tuple @@ -204,13 +205,14 @@ SYMBOL: undefined-quot { jit-execute-word 45 } { jit-execute-jump 46 } { jit-execute-call 47 } - { pic-tag 48 } - { pic-hi-tag 49 } - { pic-tuple 50 } - { pic-hi-tag-tuple 51 } - { pic-check 52 } - { pic-hit 53 } - { pic-miss-word 54 } + { pic-load 48 } + { pic-tag 49 } + { pic-hi-tag 50 } + { pic-tuple 51 } + { pic-hi-tag-tuple 52 } + { pic-check 53 } + { pic-hit 54 } + { pic-miss-word 55 } { undefined-quot 60 } } ; inline @@ -554,6 +556,7 @@ M: quotation ' jit-profiling jit-declare-word jit-save-stack + pic-load pic-tag pic-hi-tag pic-tuple diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index f7fe430162..0a69f313c1 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -46,6 +46,7 @@ CONSTANT: rt-here 5 CONSTANT: rt-this 6 CONSTANT: rt-immediate 7 CONSTANT: rt-stack-chain 8 +CONSTANT: rt-untagged 9 : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 814cb9416b..5c6373e494 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -172,17 +172,21 @@ big-endian off ! ! ! Polymorphic inline caches -! The 'make' trick lets us compute the jump distance for the conditional branches there +! Load a value from a stack position +[ + temp0 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel +] pic-load jit-define ! Tag : make-pic-tag ( -- ) - ds-reg bootstrap-cell SUB temp1 temp0 MOV temp1 tag-mask get AND temp1 tag-bits get SHL ; [ make-pic-tag ] pic-tag jit-define +! The 'make' trick lets us compute the jump distance for the conditional branches there + ! Hi-tag [ make-pic-tag diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index ef3806ca3a..e28ff677fa 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -27,6 +27,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 } { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } + [ 1- (picker) [ dip swap ] curry ] } case ; M: standard-combination picker @@ -42,7 +43,7 @@ M: standard-combination direct-entry-def ( word methods -- ) #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - picker first [ [ f inline-cache-miss ] 3curry ] keep prefix ; + combination get #>> [ f inline-cache-miss ] 3curry [ ] like ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/vm/code_block.c b/vm/code_block.c index a6d3f9590c..4331291083 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -27,6 +27,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) case RT_XT_DIRECT: case RT_IMMEDIATE: case RT_HERE: + case RT_UNTAGGED: index++; break; case RT_DLSYM: @@ -374,6 +375,9 @@ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) case RT_STACK_CHAIN: absolute_value = (CELL)&stack_chain; break; + case RT_UNTAGGED: + absolute_value = to_fixnum(array_nth(literals,index)); + break; default: critical_error("Bad rel type",rel); return; /* Can't happen */ diff --git a/vm/code_block.h b/vm/code_block.h index 9db9d32499..b8201c44a1 100644 --- a/vm/code_block.h +++ b/vm/code_block.h @@ -16,7 +16,9 @@ typedef enum { /* immediate literal */ RT_IMMEDIATE, /* address of stack_chain var */ - RT_STACK_CHAIN + RT_STACK_CHAIN, + /* untagged fixnum literal */ + RT_UNTAGGED, } F_RELTYPE; typedef enum { diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 183f25168e..0a3764c42a 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -50,17 +50,15 @@ static void update_pic_count(CELL type) pic_counts[type - PIC_TAG]++; } -/* picker: one of dup, over, pick +/* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL methods, CELL cache_entries) +static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries) { #ifdef FACTOR_DEBUG - type_check(WORD_TYPE,picker); type_check(WORD_TYPE,generic_word); type_check(ARRAY_TYPE,cache_entries); #endif - REGISTER_ROOT(picker); REGISTER_ROOT(generic_word); REGISTER_ROOT(methods); REGISTER_ROOT(cache_entries); @@ -73,7 +71,7 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL m jit_init(&jit,WORD_TYPE,generic_word); /* Generate machine code to determine the object's class. */ - jit_emit_subprimitive(&jit,untag_object(picker)); + jit_emit_with(&jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); jit_emit(&jit,userenv[inline_cache_type]); /* Generate machine code to check, in turn, if the class is one of the cached entries. */ @@ -93,12 +91,10 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL m this function being called again. The inline-cache-miss primitive call receives enough information to - reconstruct the PIC. We also execute the picker again, so that the - object being dispatched on can be popped from the top of the stack. */ - jit_emit_subprimitive(&jit,untag_object(picker)); + reconstruct the PIC. */ jit_push(&jit,generic_word); jit_push(&jit,methods); - jit_push(&jit,picker); + jit_push(&jit,tag_fixnum(index)); jit_push(&jit,cache_entries); jit_word_jump(&jit,userenv[PIC_MISS_WORD]); @@ -110,7 +106,6 @@ static F_CODE_BLOCK *compile_inline_cache(CELL picker, CELL generic_word, CELL m UNREGISTER_ROOT(cache_entries); UNREGISTER_ROOT(methods); UNREGISTER_ROOT(generic_word); - UNREGISTER_ROOT(picker); return code; } @@ -159,10 +154,10 @@ XT inline_cache_miss(CELL return_address) check_code_pointer(return_address); CELL cache_entries = dpop(); - CELL picker = dpop(); + F_FIXNUM index = untag_fixnum_fast(dpop()); CELL methods = dpop(); CELL generic_word = dpop(); - CELL object = dpop(); + CELL object = get(ds - index * CELLS); XT xt; @@ -176,17 +171,15 @@ XT inline_cache_miss(CELL return_address) { REGISTER_ROOT(generic_word); REGISTER_ROOT(cache_entries); - REGISTER_ROOT(picker); REGISTER_ROOT(methods); CELL class = object_class(object); CELL method = lookup_method(object,methods); cache_entries = add_inline_cache_entry(cache_entries,class,method); - xt = compile_inline_cache(picker,generic_word,methods,cache_entries) + 1; + xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1; UNREGISTER_ROOT(methods); - UNREGISTER_ROOT(picker); UNREGISTER_ROOT(cache_entries); UNREGISTER_ROOT(generic_word); } diff --git a/vm/run.h b/vm/run.h index 8f7ef73c0d..82aa25b680 100755 --- a/vm/run.h +++ b/vm/run.h @@ -61,7 +61,8 @@ typedef enum { JIT_EXECUTE_CALL, /* Used by polymorphic inline cache generation in inline_cache.c */ - PIC_TAG = 48, + PIC_LOAD = 48, + PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE, From 5188f4e1f0b651e6c7b12f32845906a418ddfb4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 22:23:42 -0500 Subject: [PATCH 49/83] Fix TEST opcode in cpu.x86.assembler --- basis/cpu/x86/assembler/assembler-tests.factor | 2 ++ basis/cpu/x86/assembler/assembler.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 49b0961819..203edf956e 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test + +[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 728cd04e55..5560d17a1e 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -384,7 +384,7 @@ M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: operand CMP OCT: 070 2-operand ; GENERIC: TEST ( dst src -- ) -M: immediate TEST swap { BIN: 101 t HEX: 84 } immediate-1/4 ; +M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ; M: operand TEST OCT: 204 2-operand ; : XCHG ( dst src -- ) OCT: 207 2-operand ; From 62db617927101b7d3795b2f55c187b40fee15e4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 22:24:28 -0500 Subject: [PATCH 50/83] Get rid of two instructions from tag pics and one instruction from all others --- basis/bootstrap/image/image.factor | 9 ++++-- basis/cpu/x86/bootstrap.factor | 47 ++++++++++++++++++------------ vm/inline_cache.c | 17 ++++++++++- vm/run.h | 1 + 4 files changed, 51 insertions(+), 23 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 05be047328..059d76a388 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -168,6 +168,7 @@ SYMBOL: pic-tag SYMBOL: pic-hi-tag SYMBOL: pic-tuple SYMBOL: pic-hi-tag-tuple +SYMBOL: pic-check-tag SYMBOL: pic-check SYMBOL: pic-hit SYMBOL: pic-miss-word @@ -210,9 +211,10 @@ SYMBOL: undefined-quot { pic-hi-tag 50 } { pic-tuple 51 } { pic-hi-tag-tuple 52 } - { pic-check 53 } - { pic-hit 54 } - { pic-miss-word 55 } + { pic-check-tag 53 } + { pic-check 54 } + { pic-hit 55 } + { pic-miss-word 56 } { undefined-quot 60 } } ; inline @@ -561,6 +563,7 @@ M: quotation ' pic-hi-tag pic-tuple pic-hi-tag-tuple + pic-check-tag pic-check pic-hit pic-miss-word diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 5c6373e494..325d86aa41 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -172,56 +172,65 @@ big-endian off ! ! ! Polymorphic inline caches +! temp0 contains the object being dispatched on +! temp1 contains its class + ! Load a value from a stack position [ - temp0 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel + temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel ] pic-load jit-define ! Tag -: make-pic-tag ( -- ) - temp1 temp0 MOV +[ temp1 tag-mask get AND - temp1 tag-bits get SHL ; +] pic-tag jit-define -[ make-pic-tag ] pic-tag jit-define - -! The 'make' trick lets us compute the jump distance for the conditional branches there +! The 'make' trick lets us compute the jump distance for the +! conditional branches there ! Hi-tag [ - make-pic-tag - temp1 object tag-number tag-fixnum CMP + temp0 temp1 MOV + temp1 tag-mask get AND + temp1 object tag-number CMP [ temp1 temp0 object tag-number neg [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-hi-tag jit-define ! Tuple [ - make-pic-tag - temp1 tuple tag-number tag-fixnum CMP + temp0 temp1 MOV + temp1 tag-mask get AND + temp1 tuple tag-number CMP [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-tuple jit-define ! Hi-tag and tuple [ - make-pic-tag + temp0 temp1 MOV + temp1 tag-mask get AND ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) temp1 BIN: 110 tag-fixnum CMP [ - ! Make temp0 untagged - temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 4 or 8 for tuples - temp1 1 tag-fixnum AND + ! Untag temp0 in temp2 + temp2 temp0 MOV + temp2 tag-mask get bitnot AND + ! Set temp1 to 0 for objects, and 1 for tuples + temp1 1 AND bootstrap-cell { - { 4 [ temp1 1 SHR ] } - { 8 [ ] } + { 4 [ temp1 2 SHR ] } + { 8 [ temp1 3 SHR ] } } case ! Load header cell or tuple layout cell - temp1 temp0 temp1 [+] MOV + temp1 temp2 temp1 [+] MOV ] [ ] make [ length JL ] [ % ] bi ] pic-hi-tag-tuple jit-define +[ + temp1 HEX: ffffffff CMP rc-absolute rt-untagged jit-rel +] pic-check-tag jit-define + [ temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel temp1 temp2 CMP diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 0a3764c42a..38503f5731 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -50,6 +50,17 @@ static void update_pic_count(CELL type) pic_counts[type - PIC_TAG]++; } +static void jit_emit_check(F_JIT *jit, CELL class) +{ + CELL template; + if(TAG(class) == FIXNUM_TYPE && untag_fixnum_fast(class) < HEADER_TYPE) + template = userenv[PIC_CHECK_TAG]; + else + template = userenv[PIC_CHECK]; + + jit_emit_with(jit,template,class); +} + /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries) @@ -80,7 +91,7 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CEL { /* Class equal? */ CELL class = array_nth(untag_object(cache_entries),i); - jit_emit_with(&jit,userenv[PIC_CHECK],class); + jit_emit_check(&jit,class); /* Yes? Jump to method */ CELL method = array_nth(untag_object(cache_entries),i + 1); @@ -187,6 +198,10 @@ XT inline_cache_miss(CELL return_address) /* Install the new stub. */ set_call_site(return_address,(CELL)xt); +#ifdef PIC_DEBUG + printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt); +#endif + return xt; } diff --git a/vm/run.h b/vm/run.h index 82aa25b680..c500484d25 100755 --- a/vm/run.h +++ b/vm/run.h @@ -66,6 +66,7 @@ typedef enum { PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE, + PIC_CHECK_TAG, PIC_CHECK, PIC_HIT, PIC_MISS_WORD, From 7fae35c4144bbe769c1f1a8d838bdfa18bed4e08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 22:24:36 -0500 Subject: [PATCH 51/83] Makefile: add -Werror --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 9053626291..36538b041d 100644 --- a/Makefile +++ b/Makefile @@ -9,7 +9,7 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib -CFLAGS = -Wall +CFLAGS = -Wall -Werror FFI_TEST_CFLAGS = -fPIC ifdef DEBUG From 3bbfc57de3b21cce7a8f6d68b519177cee430000 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 23:35:02 -0500 Subject: [PATCH 52/83] bootstrap.image: remove some duplication from emit-object callers --- basis/bootstrap/image/image.factor | 26 ++++++++++------------- basis/compiler/constants/constants.factor | 19 ++++++++--------- 2 files changed, 20 insertions(+), 25 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 059d76a388..a83b81d3f9 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -247,8 +247,8 @@ SYMBOL: undefined-quot : emit-fixnum ( n -- ) tag-fixnum emit ; -: emit-object ( header tag quot -- addr ) - swap here-as [ swap tag-fixnum emit call align-here ] dip ; +: emit-object ( class quot -- addr ) + over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ; inline ! Write an object to the image. @@ -293,7 +293,7 @@ GENERIC: ' ( obj -- ptr ) M: bignum ' [ - bignum tag-number dup [ emit-bignum ] emit-object + bignum [ emit-bignum ] emit-object ] cache-object ; ! Fixnums @@ -316,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ; M: float ' [ - float tag-number dup [ + float [ align-here double>bits emit-64 ] emit-object ] cache-object ; @@ -360,8 +360,7 @@ M: f ' } cleave ] { } make [ ' ] map ] bi - \ word type-number object tag-number - [ emit-seq ] emit-object + \ word [ emit-seq ] emit-object ] keep put-object ; : word-error ( word msg -- * ) @@ -382,8 +381,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped>> ' wrapper type-number object tag-number - [ emit ] emit-object ; + wrapped>> ' wrapper [ emit ] emit-object ; ! Strings : native> ( object -- object ) @@ -412,7 +410,7 @@ M: wrapper ' : emit-string ( string -- ptr ) [ length ] [ extended-part ' ] [ ] tri - string type-number object tag-number [ + string [ [ emit-fixnum ] [ emit ] [ f ' emit ascii-part pad-bytes emit-bytes ] @@ -429,12 +427,11 @@ M: string ' : emit-dummy-array ( obj type -- ptr ) [ assert-empty ] [ - type-number object tag-number [ 0 emit-fixnum ] emit-object ] bi* ; M: byte-array ' - byte-array type-number object tag-number [ + byte-array [ dup length emit-fixnum pad-bytes emit-bytes ] emit-object ; @@ -448,7 +445,7 @@ ERROR: tuple-removed class ; : (emit-tuple) ( tuple -- pointer ) [ tuple-slots ] [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map - tuple type-number dup [ emit-seq ] emit-object ; + tuple [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) dup class name>> "tombstone" = @@ -463,8 +460,7 @@ M: tombstone ' ! Arrays : emit-array ( array -- offset ) - [ ' ] map array type-number object tag-number - [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; + [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; M: array ' emit-array ; @@ -490,7 +486,7 @@ M: tuple-layout-array ' M: quotation ' [ array>> ' - quotation type-number object tag-number [ + quotation [ emit ! array f ' emit ! compiled f ' emit ! cached-effect diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 0a69f313c1..d384109cee 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel layouts system strings ; +USING: math kernel layouts system strings words quotations byte-arrays alien ; IN: compiler.constants ! These constants must match vm/memory.h @@ -11,16 +11,15 @@ CONSTANT: deck-bits 18 ! These constants must match vm/layouts.h : header-offset ( -- n ) object tag-number neg ; inline : float-offset ( -- n ) 8 float tag-number - ; inline -: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline +: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline -: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline -: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline -: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline +: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline +: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline +: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline +: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline -: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline +: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline +: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline From 9f4ac667dc5d76b57956d798d5a88cd67d2fab49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Apr 2009 23:36:05 -0500 Subject: [PATCH 53/83] Move some unit tests from generic to generic.math --- core/generic/generic-tests.factor | 9 --------- core/generic/math/math-tests.factor | 16 ++++++++++++++++ 2 files changed, 16 insertions(+), 9 deletions(-) create mode 100644 core/generic/math/math-tests.factor diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e7ae583aa6..a63cab1c5c 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -96,15 +96,6 @@ M: shit big-generic-test "shit" ; [ t ] [ \ + math-generic? ] unit-test -! Test math-combination -[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test -[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test -[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test -[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test -[ number ] [ \ number \ float math-class-max ] unit-test -[ float ] [ \ real \ float math-class-max ] unit-test -[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test - ! Regression TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor new file mode 100644 index 0000000000..12baeb64b5 --- /dev/null +++ b/core/generic/math/math-tests.factor @@ -0,0 +1,16 @@ +IN: generic.math.tests +USING: generic.math math tools.test ; + +! Test math-combination +[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test +[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test +[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test +[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test + +[ number ] [ \ number \ float math-class-max ] unit-test +[ float ] [ \ real \ float math-class-max ] unit-test +[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test +[ bignum ] [ \ fixnum \ bignum math-class-max ] unit-test +[ number ] [ \ fixnum \ number math-class-max ] unit-test + + From fc4894fbdfa5fddd0a42a3c7ce82ba169eae3887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 00:27:35 -0500 Subject: [PATCH 54/83] Replace ratio and complex built-in types with tuples defined in the library. This frees up two lo-tags, so move array and quotation over to these tags and update compiler for new tags --- .../cfg/intrinsics/allot/allot.factor | 28 ++--- .../compiler/cfg/intrinsics/intrinsics.factor | 4 - basis/compiler/tests/intrinsics.factor | 4 +- .../tree/escape-analysis/check/check.factor | 1 - .../escape-analysis-tests.factor | 4 +- .../tree/escape-analysis/simple/simple.factor | 4 - .../tree/propagation/propagation-tests.factor | 6 +- .../tree/propagation/simple/simple.factor | 2 +- .../tree/propagation/slots/slots.factor | 16 +-- .../tuple-unboxing-tests.factor | 1 - .../tree/tuple-unboxing/tuple-unboxing.factor | 4 - basis/math/complex/complex-docs.factor | 4 - basis/math/complex/complex.factor | 6 +- basis/math/functions/functions-docs.factor | 5 - basis/math/functions/functions.factor | 13 +- basis/math/ratios/ratios-docs.factor | 3 - basis/math/ratios/ratios.factor | 2 +- .../known-words/known-words.factor | 6 - core/bootstrap/layouts/layouts.factor | 24 ++-- core/bootstrap/primitives.factor | 32 ----- core/generic/math/math-docs.factor | 2 +- core/generic/math/math.factor | 111 +++++++++++------- core/math/math.factor | 11 +- vm/arrays.c | 47 +++++--- vm/arrays.h | 9 +- vm/byte_arrays.c | 28 +++-- vm/callstack.c | 4 +- vm/cpu-x86.32.S | 2 +- vm/cpu-x86.64.S | 2 +- vm/data_heap.c | 22 ++-- vm/dispatch.c | 6 +- vm/factor.c | 2 +- vm/inline_cache.c | 2 +- vm/layouts.h | 36 ++---- vm/local_roots.h | 2 +- vm/math.c | 22 ---- vm/math.h | 4 - vm/primitives.c | 2 - vm/quotations.c | 2 +- vm/quotations.h | 5 + vm/run.c | 2 +- vm/run.h | 13 +- vm/strings.c | 70 +++++++---- vm/tuples.c | 2 +- 44 files changed, 265 insertions(+), 312 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 3a4c702bc5..938dbbccbf 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot [ tuple ##set-slots ] [ ds-push drop ] 2bi ] [ drop emit-primitive ] if ; -: store-length ( len reg -- ) - [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ; +: store-length ( len reg class -- ) + [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ; -: store-initial-element ( elt reg len -- ) - [ 2 + object tag-number ##set-slot-imm ] with with each ; +:: store-initial-element ( len reg elt class -- ) + len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; @@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot [let | elt [ ds-pop ] reg [ len ^^allot-array ] | ds-drop - len reg store-length - elt reg len store-initial-element + len reg array store-length + len reg elt array store-initial-element reg ds-push ] ] [ node emit-primitive ] if @@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot : emit-allot-byte-array ( len -- dst ) ds-drop dup ^^allot-byte-array - [ store-length ] [ ds-push ] [ ] tri ; + [ byte-array store-length ] [ ds-push ] [ ] tri ; : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-? [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; -: emit- ( node -- ) - dup node-input-infos first literal>> dup expand-? [ - nip - [ 0 ^^load-literal ] dip - [ emit-allot-byte-array ] keep - bytes>cells store-initial-element - ] [ drop emit-primitive ] if ; +:: emit- ( node -- ) + node node-input-infos first literal>> dup expand-? [ + :> len + 0 ^^load-literal :> elt + len emit-allot-byte-array :> reg + len reg elt byte-array store-initial-element + ] [ drop node emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 3d0a7bec9c..ec819f9440 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics arrays: byte-arrays: byte-arrays:(byte-array) - math.private: - math.private: kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 @@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } { \ kernel: [ emit-simple-allot iterate-next ] } { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index a6e827ea33..5ca0f3f109 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -342,12 +342,12 @@ cell 8 = [ ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call + 1 2 [ complex boa ] compile-call dup real-part swap imaginary-part ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call dup numerator swap denominator + 1 2 [ ratio boa ] compile-call dup numerator swap denominator ] unit-test [ \ + ] [ \ + [ ] compile-call ] unit-test diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor index 333b3fa636..ed253ad89b 100644 --- a/basis/compiler/tree/escape-analysis/check/check.factor +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -12,7 +12,6 @@ M: #push run-escape-analysis* M: #call run-escape-analysis* { - { [ dup word>> \ eq? ] [ t ] } { [ dup immutable-tuple-boa? ] [ t ] } [ f ] } cond nip ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index bcb8b2f80a..5f89372ebe 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n ) out-d>> first escaping-allocation? [ 1+ ] unless ; M: #call count-unboxed-allocations* - dup [ immutable-tuple-boa? ] [ word>> \ eq? ] bi or + dup immutable-tuple-boa? [ (count-unboxed-allocations) ] [ drop ] if ; M: #push count-unboxed-allocations* @@ -291,7 +291,7 @@ C: ro-box [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test -[ 1 ] [ [ >rect ] count-unboxed-allocations ] unit-test +[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index fe1e60dbc2..729d6a0490 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -47,9 +47,6 @@ M: #push escape-analysis* [ record-unknown-allocation ] if ; -: record-complex-allocation ( #call -- ) - [ in-d>> ] [ out-d>> first ] bi record-allocation ; - : slot-offset ( #call -- n/f ) dup in-d>> [ first node-value-info class>> ] @@ -71,7 +68,6 @@ M: #push escape-analysis* M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } - { \ [ record-complex-allocation ] } { \ slot [ record-slot-call ] } [ drop record-unknown-allocation ] } case ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f6308ac40a..ed8d2983b5 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; ] unit-test [ V{ complex } ] [ - [ ] final-classes + [ complex boa ] final-classes ] unit-test [ V{ complex } ] [ @@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; [ V{ complex } ] [ [ { float float object } declare - [ "Oops" throw ] [ ] if + [ "Oops" throw ] [ complex boa ] if ] final-classes ] unit-test @@ -590,7 +590,7 @@ MIXIN: empty-mixin [ V{ float } ] [ [ - [ { float float } declare ] + [ { float float } declare complex boa ] [ 2drop C{ 0.0 0.0 } ] if real-part ] final-classes diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 9937c6b9c4..5837d59ef9 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -109,7 +109,7 @@ M: #declare propagate-before : output-value-infos ( #call word -- infos ) { - { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } + { [ dup \ eq? ] [ drop propagate- ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup predicate? ] [ propagate-predicate ] } { [ dup "outputs" word-prop ] [ call-outputs-quot ] } diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 8192b1c520..1e221c89f1 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -29,9 +29,6 @@ UNION: fixed-length-sequence array byte-array string ; [ constructor-output-class ] bi* value-info-intersect 1array ; -: tuple-constructor? ( word -- ? ) - { } memq? ; - : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple ; @@ -44,18 +41,9 @@ UNION: fixed-length-sequence array byte-array string ; ] if ; -: propagate- ( #call -- info ) +: propagate- ( #call -- infos ) in-d>> unclip-last - value-info literal>> first (propagate-tuple-constructor) ; - -: propagate- ( #call -- info ) - in-d>> [ value-info ] map complex ; - -: propagate-tuple-constructor ( #call word -- infos ) - { - { \ [ propagate- ] } - { \ [ propagate- ] } - } case 1array ; + value-info literal>> first (propagate-tuple-constructor) 1array ; : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 8654a6f983..70670648b1 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -32,7 +32,6 @@ TUPLE: empty-tuple ; [ dup [ drop f ] [ "A" throw ] if ] [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ] [ [ ] [ ] curry curry call ] - [ dup 1 slot drop 2 slot drop ] [ 1 cons boa over [ "A" throw ] when car>> ] [ [ <=> ] sort ] [ [ <=> ] with search ] diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 1e00efa835..107ea59902 100755 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ in-d>> 1 tail* #drop ] when ; -: unbox- ( #call -- nodes ) - dup unbox-output? [ drop { } ] when ; - : (flatten-values) ( values accum -- ) dup '[ dup unboxed-allocation @@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes ) M: #call unbox-tuples* dup word>> { { \ [ unbox- ] } - { \ [ unbox- ] } { \ slot [ unbox-slot-access ] } [ drop ] } case ; diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index 6b6f5c95bd..a51b86ff0b 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -25,7 +25,3 @@ HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; ABOUT: "complex-numbers" - -HELP: ( x y -- z ) -{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } } -{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ; diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index c41faaf558..832a9e64ba 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -15,14 +15,14 @@ M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; : complex= ( x y quot -- ? ) componentwise and ; inline M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; M: complex number= [ number= ] complex= ; -: complex-op ( x y quot -- z ) componentwise (rect>) ; inline +: complex-op ( x y quot -- z ) componentwise rect> ; inline M: complex + [ + ] complex-op ; M: complex - [ - ] complex-op ; : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi (rect>) ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline -: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ (rect>) ; inline +: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline M: complex / [ / ] complex/ ; M: complex /f [ /f ] complex/ ; M: complex /i [ /i ] complex/ ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f7d0d5a941..48da8aa6ec 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -100,11 +100,6 @@ ARTICLE: "math-functions" "Mathematical functions" ABOUT: "math-functions" -HELP: (rect>) -{ $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } -{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; - HELP: rect> { $values { "x" real } { "y" real } { "z" number } } { $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a6beb87345..c21053317e 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -7,19 +7,8 @@ IN: math.functions : >fraction ( a/b -- a b ) [ numerator ] [ denominator ] bi ; inline -) ( x y -- z ) - dup 0 = [ drop ] [ ] if ; inline - -PRIVATE> - : rect> ( x y -- z ) - 2dup [ real? ] both? [ - (rect>) - ] [ - "Complex number must have real components" throw - ] if ; inline + dup 0 = [ drop ] [ complex boa ] if ; inline GENERIC: sqrt ( x -- y ) foldable diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor index 7b6393dabe..2e51fa1870 100644 --- a/basis/math/ratios/ratios-docs.factor +++ b/basis/math/ratios/ratios-docs.factor @@ -47,6 +47,3 @@ HELP: 2>fraction { $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } } { $description "Extracts the numerator and denominator of two rational numbers at once." } ; -HELP: ( a b -- a/b ) -{ $values { "a" integer } { "b" integer } { "a/b" "a ratio" } } -{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ; diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 54e4bee1a8..d4f457180e 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -9,7 +9,7 @@ IN: math.ratios ( a b -- a/b ) - dup 1 number= [ drop ] [ ] if ; inline + dup 1 number= [ drop ] [ ratio boa ] if ; inline : scale ( a/b c/d -- a*d b*c ) 2>fraction [ * swap ] dip * swap ; inline diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0bbaa32c25..72eead1826 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -286,9 +286,6 @@ M: object infer-call* \ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable -\ { integer integer } { ratio } define-primitive -\ make-foldable - \ string>float { string } { float } define-primitive \ string>float make-foldable @@ -307,9 +304,6 @@ M: object infer-call* \ bits>double { integer } { float } define-primitive \ bits>double make-foldable -\ { real real } { complex } define-primitive -\ make-foldable - \ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 264756ab9b..0243ad040e 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays @@ -9,14 +9,14 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -17 num-types set +15 num-types set H{ { fixnum BIN: 000 } { bignum BIN: 001 } - { ratio BIN: 010 } + { array BIN: 010 } { float BIN: 011 } - { complex BIN: 100 } + { quotation BIN: 100 } { POSTPONE: f BIN: 101 } { object BIN: 110 } { hi-tag BIN: 110 } @@ -24,13 +24,11 @@ H{ } tag-numbers set tag-numbers get H{ - { array 8 } - { wrapper 9 } - { byte-array 10 } - { callstack 11 } - { string 12 } - { word 13 } - { quotation 14 } - { dll 15 } - { alien 16 } + { wrapper 8 } + { byte-array 9 } + { callstack 10 } + { string 11 } + { word 12 } + { dll 13 } + { alien 14 } } assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a3b4a91aeb..2d2963c1d8 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -126,9 +126,7 @@ bootstrapping? on "fixnum" "math" create register-builtin "bignum" "math" create register-builtin "tuple" "kernel" create register-builtin -"ratio" "math" create register-builtin "float" "math" create register-builtin -"complex" "math" create register-builtin "f" "syntax" lookup register-builtin "array" "arrays" create register-builtin "wrapper" "kernel" create register-builtin @@ -147,24 +145,6 @@ bootstrapping? on "f?" "syntax" vocab-words delete-at ! Some unions -"integer" "math" create -"fixnum" "math" lookup -"bignum" "math" lookup -2array -define-union-class - -"rational" "math" create -"integer" "math" lookup -"ratio" "math" lookup -2array -define-union-class - -"real" "math" create -"rational" "math" lookup -"float" "math" lookup -2array -define-union-class - "c-ptr" "alien" create [ "alien" "alien" lookup , "f" "syntax" lookup , @@ -211,19 +191,9 @@ bi "bignum" "math" create { } define-builtin "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop -"ratio" "math" create { - { "numerator" { "integer" "math" } read-only } - { "denominator" { "integer" "math" } read-only } -} define-builtin - "float" "math" create { } define-builtin "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop -"complex" "math" create { - { "real" { "real" "math" } read-only } - { "imaginary" { "real" "math" } read-only } -} define-builtin - "array" "arrays" create { { "length" { "array-capacity" "sequences.private" } read-only } } define-builtin @@ -395,14 +365,12 @@ tuple { "float>bignum" "math.private" (( x -- y )) } { "fixnum>float" "math.private" (( x -- y )) } { "bignum>float" "math.private" (( x -- y )) } - { "" "math.private" (( a b -- a/b )) } { "string>float" "math.private" (( str -- n/f )) } { "float>string" "math.private" (( n -- str )) } { "float>bits" "math" (( x -- n )) } { "double>bits" "math" (( x -- n )) } { "bits>float" "math" (( n -- x )) } { "bits>double" "math" (( n -- x )) } - { "" "math.private" (( x y -- z )) } { "fixnum+" "math.private" (( x y -- z )) } { "fixnum-" "math.private" (( x y -- z )) } { "fixnum*" "math.private" (( x y -- z )) } diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 60fa745339..7d7d6e725b 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -1,5 +1,5 @@ USING: kernel generic help.markup help.syntax math classes -sequences quotations ; +sequences quotations generic.math.private ; IN: generic.math HELP: math-upgrade diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8d4610dabe..f7e79e68bd 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math -namespaces make sequences words quotations layouts combinators +namespaces sequences words quotations layouts combinators sequences.private classes classes.builtin classes.algebra -definitions math.order math.private ; +definitions math.order math.private assocs ; IN: generic.math PREDICATE: math-class < class @@ -13,24 +13,30 @@ PREDICATE: math-class < class number bootstrap-word class<= ] if ; + ( class1 class2 -- class ) - [ math-precedence ] compare +gt+ eq? ; +: bootstrap-words ( classes -- classes' ) + [ bootstrap-word ] map ; -: math-class-max ( class1 class2 -- class ) - [ math-class<=> ] most ; +: math-precedence ( class -- pair ) + [ + { null fixnum bignum ratio float complex object } bootstrap-words + swap [ class<= ] curry find drop + ] [ + { null fixnum integer rational real number object } bootstrap-words + swap [ swap class<= ] curry find drop + ] bi 2array ; : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; +PRIVATE> + +: math-class-max ( class1 class2 -- class ) + [ [ math-precedence ] bi@ after? ] most ; + : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep [ @@ -44,33 +50,57 @@ ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; + + : object-method ( generic -- quot ) object bootstrap-word applicable-method ; : math-method ( word class1 class2 -- quot ) 2dup and [ - [ - 2dup 2array , \ declare , - 2dup math-upgrade % - math-class-max over order min-class applicable-method % - ] [ ] make + [ 2array [ declare ] curry nip ] + [ math-upgrade nip ] + [ math-class-max over order min-class applicable-method ] + 3tri 3append ] [ 2drop object-method ] if ; -SYMBOL: picker +class ] prepose map , ] bi* - \ dispatch , - ] [ ] make ; inline +SYMBOL: generic-word + +: make-math-method-table ( classes quot: ( class -- quot ) -- alist ) + [ bootstrap-words ] dip + [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline + +: math-alist>quot ( alist -- quot ) + [ generic-word get object-method ] dip alist>quot ; + +: tag-dispatch-entry ( tag picker -- quot ) + [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ; + +: tag-dispatch ( picker alist -- alist' ) + swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: tuple-dispatch-entry ( class picker -- quot ) + [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ; + +: tuple-dispatch ( picker alist -- alist' ) + swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: math-dispatch-step ( picker quot: ( class -- quot ) -- quot ) + [ [ { bignum float fixnum } ] dip make-math-method-table ] + [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi + tuple swap 2array prefix tag-dispatch ; inline + +PRIVATE> SINGLETON: math-combination @@ -78,20 +108,21 @@ M: math-combination make-default-method drop default-math-method ; M: math-combination perform-combination - drop - dup - [ - [ 2dup both-fixnums? ] % - dup fixnum bootstrap-word dup math-method , - \ over [ - dup math-class? [ - \ dup [ [ 2dup ] dip math-method ] math-vtable - ] [ - over object-method - ] if nip - ] math-vtable nip , - \ if , - ] [ ] make define ; + drop dup generic-word [ + dup + [ fixnum bootstrap-word dup math-method ] + [ + [ over ] [ + dup math-class? [ + [ dup ] [ math-method ] with with math-dispatch-step + ] [ + drop object-method + ] if + ] with math-dispatch-step + ] bi + [ if ] 2curry [ 2dup both-fixnums? ] prepend + define + ] with-variable ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/math/math.factor b/core/math/math.factor index 42786ffc9d..993d8d0e76 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -63,23 +63,22 @@ PRIVATE> : neg ( x -- -x ) 0 swap - ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline - : ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline - : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable - : 2^ ( n -- 2^n ) 1 swap shift ; inline - : even? ( n -- ? ) 1 bitand zero? ; - : odd? ( n -- ? ) 1 bitand 1 number= ; UNION: integer fixnum bignum ; +TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ; + UNION: rational integer ratio ; UNION: real rational float ; +TUPLE: complex { real real read-only } { imaginary real read-only } ; + UNION: number real complex ; GENERIC: fp-nan? ( x -- ? ) diff --git a/vm/arrays.c b/vm/arrays.c index 3f0de35262..4d5dc67818 100644 --- a/vm/arrays.c +++ b/vm/arrays.c @@ -34,7 +34,7 @@ void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); - dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); + dpush(tag_array(allot_array(ARRAY_TYPE,size,initial))); } CELL allot_array_1(CELL obj) @@ -43,7 +43,7 @@ CELL allot_array_1(CELL obj) F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); UNREGISTER_ROOT(obj); set_array_nth(a,0,obj); - return tag_object(a); + return tag_array(a); } CELL allot_array_2(CELL v1, CELL v2) @@ -55,7 +55,7 @@ CELL allot_array_2(CELL v1, CELL v2) UNREGISTER_ROOT(v1); set_array_nth(a,0,v1); set_array_nth(a,1,v2); - return tag_object(a); + return tag_array(a); } CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) @@ -73,35 +73,48 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) set_array_nth(a,1,v2); set_array_nth(a,2,v3); set_array_nth(a,3,v4); - return tag_object(a); + return tag_array(a); } -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) +static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + +F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity) { #ifdef FACTOR_DEBUG CELL header = untag_header(array->header); assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); #endif - CELL to_copy = array_capacity(array); - if(capacity < to_copy) + if(reallot_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(array); - F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); - UNREGISTER_UNTAGGED(array); + REGISTER_UNTAGGED(array); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * CELLS); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - - return new_array; + return new_array; + } } void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity))); + dpush(tag_array(reallot_array(array,capacity))); } void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) @@ -112,7 +125,7 @@ void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) if(array->count == array_capacity(underlying)) { underlying = reallot_array(underlying,array->count * 2); - array->array = tag_object(underlying); + array->array = tag_array(underlying); } UNREGISTER_ROOT(elt); @@ -131,7 +144,7 @@ void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) if(new_size >= array_capacity(underlying)) { underlying = reallot_array(underlying,new_size * 2); - array->array = tag_object(underlying); + array->array = tag_array(underlying); } UNREGISTER_UNTAGGED(elts); diff --git a/vm/arrays.h b/vm/arrays.h index 4d773922b4..3b2a065aba 100644 --- a/vm/arrays.h +++ b/vm/arrays.h @@ -1,5 +1,10 @@ DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) +INLINE CELL tag_array(F_ARRAY *array) +{ + return RETAG(array,ARRAY_TYPE); +} + /* Inline functions */ INLINE CELL array_size(CELL size) { @@ -61,7 +66,7 @@ INLINE F_GROWABLE_ARRAY make_growable_array(void) { F_GROWABLE_ARRAY result; result.count = 0; - result.array = tag_object(allot_array(ARRAY_TYPE,100,F)); + result.array = tag_array(allot_array(ARRAY_TYPE,100,F)); return result; } @@ -80,7 +85,7 @@ void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) { - array->array = tag_object(reallot_array(untag_object(array->array),array->count)); + array->array = tag_array(reallot_array(untag_object(array->array),array->count)); } #define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c index 42fd5ba274..480b4d7a9f 100644 --- a/vm/byte_arrays.c +++ b/vm/byte_arrays.c @@ -30,23 +30,35 @@ void primitive_uninitialized_byte_array(void) dpush(tag_object(allot_byte_array_internal(size))); } +static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) { #ifdef FACTOR_DEBUG assert(untag_header(array->header) == BYTE_ARRAY_TYPE); #endif - - CELL to_copy = array_capacity(array); - if(capacity < to_copy) + if(reallot_byte_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); - UNREGISTER_UNTAGGED(array); + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); + UNREGISTER_UNTAGGED(array); - memcpy(new_array + 1,array + 1,to_copy); + memcpy(new_array + 1,array + 1,to_copy); - return new_array; + return new_array; + } } void primitive_resize_byte_array(void) diff --git a/vm/callstack.c b/vm/callstack.c index b7e6b946bb..26f8589c29 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -170,7 +170,7 @@ void primitive_callstack_to_array(void) frame_index = 0; iterate_callstack_object(stack,stack_frame_to_array); - dpush(tag_object(array)); + dpush(tag_array(array)); } F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) @@ -214,7 +214,7 @@ void primitive_set_innermost_stack_frame_quot(void) REGISTER_UNTAGGED(callstack); REGISTER_UNTAGGED(quot); - jit_compile(tag_object(quot),true); + jit_compile(tag_quotation(quot),true); UNREGISTER_UNTAGGED(quot); UNREGISTER_UNTAGGED(callstack); diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index cfac257ff3..3c0db36935 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -29,7 +29,7 @@ and the callstack top is passed in EDX */ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 14 +#define QUOT_XT_OFFSET 16 #define WORD_XT_OFFSET 30 /* We pass a function pointer to memcpy to work around a Mac OS X diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 984f7d1842..26cb753d59 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 34 +#define QUOT_XT_OFFSET 36 #define WORD_XT_OFFSET 66 /* We pass a function pointer to memcpy to work around a Mac OS X diff --git a/vm/data_heap.c b/vm/data_heap.c index 44232ab6b0..cab9114089 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -216,12 +216,8 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_QUOTATION); case WORD_TYPE: return sizeof(F_WORD); - case RATIO_TYPE: - return sizeof(F_RATIO); case FLOAT_TYPE: return sizeof(F_FLOAT); - case COMPLEX_TYPE: - return sizeof(F_COMPLEX); case DLL_TYPE: return sizeof(F_DLL); case ALIEN_TYPE: @@ -276,10 +272,6 @@ CELL binary_payload_start(CELL pointer) tuple = untag_object(pointer); layout = untag_object(tuple->layout); return tuple_size(layout); - case RATIO_TYPE: - return sizeof(F_RATIO); - case COMPLEX_TYPE: - return sizeof(F_COMPLEX); case WRAPPER_TYPE: return sizeof(F_WRAPPER); default: @@ -291,20 +283,22 @@ CELL binary_payload_start(CELL pointer) /* Push memory usage statistics in data heap */ void primitive_data_room(void) { - F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F); - int gen; - dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); + GROWABLE_ARRAY(a); + + int gen; for(gen = 0; gen < data_heap->gen_count; gen++) { F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); - set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10)); - set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10)); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10)); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10)); } - dpush(tag_object(a)); + GROWABLE_ARRAY_TRIM(a); + GROWABLE_ARRAY_DONE(a); + dpush(a); } /* Disables GC and activates next-object ( -- obj ) primitive */ diff --git a/vm/dispatch.c b/vm/dispatch.c index 492b29ac17..507725458e 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -74,7 +74,11 @@ static CELL lookup_tuple_method(CELL object, CELL methods) static CELL lookup_hi_tag_method(CELL object, CELL methods) { F_ARRAY *hi_tag_methods = untag_object(methods); - return array_nth(hi_tag_methods,hi_tag(object) - HEADER_TYPE); + CELL tag = hi_tag(object) - HEADER_TYPE; +#ifdef FACTOR_DEBUG + assert(tag < TYPE_COUNT - HEADER_TYPE); +#endif + return array_nth(hi_tag_methods,tag); } static CELL method_cache_hashcode(CELL key, F_ARRAY *array) diff --git a/vm/factor.c b/vm/factor.c index 56a72d5c1e..0a652f7aab 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -167,7 +167,7 @@ void pass_args_to_factor(int argc, F_CHAR **argv) set_array_nth(args,i,arg); } - userenv[ARGS_ENV] = tag_object(args); + userenv[ARGS_ENV] = tag_array(args); } void start_factor(F_PARAMETERS *p) diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 38503f5731..4d10074ae6 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -144,7 +144,7 @@ static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method) cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); set_array_nth(cache_entries_array,pic_size,class); set_array_nth(cache_entries_array,pic_size + 1,method); - return tag_object(cache_entries_array); + return tag_array(cache_entries_array); } } diff --git a/vm/layouts.h b/vm/layouts.h index 27bbe5b137..fd30f1bfa2 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -32,9 +32,9 @@ typedef signed long long s64; /*** Tags ***/ #define FIXNUM_TYPE 0 #define BIGNUM_TYPE 1 -#define RATIO_TYPE 2 +#define ARRAY_TYPE 2 #define FLOAT_TYPE 3 -#define COMPLEX_TYPE 4 +#define QUOTATION_TYPE 4 #define F_TYPE 5 #define OBJECT_TYPE 6 #define TUPLE_TYPE 7 @@ -50,17 +50,15 @@ typedef signed long long s64; #define GC_COLLECTED 5 /* See gc.c */ /*** Header types ***/ -#define ARRAY_TYPE 8 -#define WRAPPER_TYPE 9 -#define BYTE_ARRAY_TYPE 10 -#define CALLSTACK_TYPE 11 -#define STRING_TYPE 12 -#define WORD_TYPE 13 -#define QUOTATION_TYPE 14 -#define DLL_TYPE 15 -#define ALIEN_TYPE 16 +#define WRAPPER_TYPE 8 +#define BYTE_ARRAY_TYPE 9 +#define CALLSTACK_TYPE 10 +#define STRING_TYPE 11 +#define WORD_TYPE 12 +#define DLL_TYPE 13 +#define ALIEN_TYPE 14 -#define TYPE_COUNT 17 +#define TYPE_COUNT 15 INLINE bool immediate_p(CELL obj) { @@ -175,13 +173,6 @@ typedef struct { CELL object; } F_WRAPPER; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - CELL numerator; - CELL denominator; -} F_RATIO; - /* Assembly code makes assumptions about the layout of this struct */ typedef struct { /* We use a union here to force the float value to be aligned on an @@ -210,13 +201,6 @@ typedef struct { F_CODE_BLOCK *code; } F_QUOTATION; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - CELL real; - CELL imaginary; -} F_COMPLEX; - /* Assembly code makes assumptions about the layout of this struct */ typedef struct { CELL header; diff --git a/vm/local_roots.h b/vm/local_roots.h index 59f1bfc4e6..bbedf46394 100644 --- a/vm/local_roots.h +++ b/vm/local_roots.h @@ -38,7 +38,7 @@ CELL extra_roots; DEFPUSHPOP(root_,extra_roots) -#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) +#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) /* We ignore strings which point outside the data heap, but we might be given diff --git a/vm/math.c b/vm/math.c index 7bff0de387..25180abdd6 100644 --- a/vm/math.c +++ b/vm/math.c @@ -375,18 +375,6 @@ CELL unbox_array_size(void) return 0; /* can't happen */ } -/* Ratios */ - -/* Does not reduce to lowest terms, so should only be used by math -library implementation, to avoid breaking invariants. */ -void primitive_from_fraction(void) -{ - F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO)); - ratio->denominator = dpop(); - ratio->numerator = dpop(); - dpush(RETAG(ratio,RATIO_TYPE)); -} - /* Floats */ void primitive_fixnum_to_float(void) { @@ -525,13 +513,3 @@ void box_double(double flo) { dpush(allot_float(flo)); } - -/* Complex numbers */ - -void primitive_from_rect(void) -{ - F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - z->imaginary = dpop(); - z->real = dpop(); - dpush(RETAG(z,COMPLEX_TYPE)); -} diff --git a/vm/math.h b/vm/math.h index f94f12b76d..4a18888549 100644 --- a/vm/math.h +++ b/vm/math.h @@ -85,8 +85,6 @@ DLLEXPORT u64 to_unsigned_8(CELL obj); CELL unbox_array_size(void); -void primitive_from_fraction(void); - INLINE double untag_float_fast(CELL tagged) { return ((F_FLOAT*)UNTAG(tagged))->n; @@ -151,5 +149,3 @@ void primitive_float_bits(void); void primitive_bits_float(void); void primitive_double_bits(void); void primitive_bits_double(void); - -void primitive_from_rect(void); diff --git a/vm/primitives.c b/vm/primitives.c index 3e9a829a2e..61bc01a22e 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -7,14 +7,12 @@ void *primitives[] = { primitive_float_to_bignum, primitive_fixnum_to_float, primitive_bignum_to_float, - primitive_from_fraction, primitive_str_to_float, primitive_float_to_str, primitive_float_bits, primitive_double_bits, primitive_bits_float, primitive_bits_double, - primitive_from_rect, primitive_fixnum_add, primitive_fixnum_subtract, primitive_fixnum_multiply, diff --git a/vm/quotations.c b/vm/quotations.c index 4b5eb0dd2c..255289b407 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -439,7 +439,7 @@ void primitive_array_to_quotation(void) quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; - drepl(tag_object(quot)); + drepl(tag_quotation(quot)); } void primitive_quotation_xt(void) diff --git a/vm/quotations.h b/vm/quotations.h index 6fcd894b05..16ef9df422 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,5 +1,10 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) +INLINE CELL tag_quotation(F_QUOTATION *quotation) +{ + return RETAG(quotation,QUOTATION_TYPE); +} + void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vm/run.c b/vm/run.c index 7dc2474113..f5e45c2d5a 100755 --- a/vm/run.c +++ b/vm/run.c @@ -120,7 +120,7 @@ bool stack_to_array(CELL bottom, CELL top) { F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); memcpy(a + 1,(void*)bottom,depth); - dpush(tag_object(a)); + dpush(tag_array(a)); return true; } } diff --git a/vm/run.h b/vm/run.h index c500484d25..b8f27de5ae 100755 --- a/vm/run.h +++ b/vm/run.h @@ -153,16 +153,19 @@ INLINE CELL untag_header(CELL cell) return cell >> TAG_BITS; } -INLINE CELL tag_object(void* cell) -{ - return RETAG(cell,OBJECT_TYPE); -} - INLINE CELL hi_tag(CELL tagged) { return untag_header(get(UNTAG(tagged))); } +INLINE CELL tag_object(void *cell) +{ +#ifdef FACTOR_DEBUG + assert(hi_tag((CELL)cell) >= HEADER_TYPE); +#endif + return RETAG(cell,OBJECT_TYPE); +} + INLINE CELL type_of(CELL tagged) { CELL tag = TAG(tagged); diff --git a/vm/strings.c b/vm/strings.c index 03414077b9..f08a2e8866 100644 --- a/vm/strings.c +++ b/vm/strings.c @@ -107,40 +107,60 @@ void primitive_string(void) dpush(tag_object(allot_string(length,initial))); } +static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) +{ + return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); +} + F_STRING* reallot_string(F_STRING* string, CELL capacity) { - CELL to_copy = string_capacity(string); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(string); - F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_UNTAGGED(string); - - memcpy(new_string + 1,string + 1,to_copy); - - if(string->aux != F) + if(reallot_string_in_place_p(string,capacity)) { + string->length = tag_fixnum(capacity); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + aux->capacity = tag_fixnum(capacity * 2); + } + + return string; + } + else + { + CELL to_copy = string_capacity(string); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(string); + F_STRING *new_string = allot_string_internal(capacity); + UNREGISTER_UNTAGGED(string); + + memcpy(new_string + 1,string + 1,to_copy); + + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + write_barrier((CELL)new_string); + new_string->aux = tag_object(new_aux); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + REGISTER_UNTAGGED(string); REGISTER_UNTAGGED(new_string); - F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + fill_string(new_string,to_copy,capacity,'\0'); UNREGISTER_UNTAGGED(new_string); UNREGISTER_UNTAGGED(string); - write_barrier((CELL)new_string); - new_string->aux = tag_object(new_aux); - - F_BYTE_ARRAY *aux = untag_object(string->aux); - memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + return new_string; } - - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,'\0'); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - return new_string; } void primitive_resize_string(void) diff --git a/vm/tuples.c b/vm/tuples.c index 0ad7557179..c93bdf4669 100644 --- a/vm/tuples.c +++ b/vm/tuples.c @@ -6,7 +6,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) REGISTER_UNTAGGED(layout); F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); UNREGISTER_UNTAGGED(layout); - tuple->layout = tag_object(layout); + tuple->layout = tag_array((F_ARRAY *)layout); return tuple; } From 663db67b23fb0b93b772d81f9ee4f651d4447227 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 00:27:51 -0500 Subject: [PATCH 55/83] compiler.tree.debugger: wasn't counting intrinsics properly when computing report --- basis/compiler/tree/debugger/debugger.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index b1dc04082e..60cab92843 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -153,7 +153,7 @@ SYMBOL: node-count [ 1+ ] dip dup #call? [ word>> { - { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } + { [ dup "intrinsic" word-prop ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } [ words-called ] From 964fbd0a242529580eaeda32294e5ebc84fef70b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 00:38:55 -0500 Subject: [PATCH 56/83] Fix test failures from ratio/complex built-in removal --- basis/compiler/tests/codegen.factor | 2 +- .../compiler/tree/propagation/info/info.factor | 16 ++++------------ .../tree/propagation/slots/slots.factor | 5 +---- core/generic/math/math-tests.factor | 17 +++++++++++------ core/generic/math/math.factor | 8 ++++---- 5 files changed, 21 insertions(+), 27 deletions(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index e45246fc17..8fbe13ce51 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -26,7 +26,7 @@ IN: compiler.tests.codegen [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test -[ { 1 2 3 } { 1 4 3 } 6 6 ] +[ { 1 2 3 } { 1 4 3 } 2 2 ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index a22b7aa172..2776ed914f 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -70,18 +70,10 @@ DEFER: dup literal>> class >>class dup literal>> dup real? [ [a,a] >>interval ] [ [ [-inf,inf] >>interval ] dip - { - { [ dup complex? ] [ - [ real-part ] - [ imaginary-part ] bi - 2array >>slots - ] } - { [ dup tuple? ] [ - [ tuple-slots [ ] map ] [ class ] bi - read-only-slots >>slots - ] } - [ drop ] - } cond + dup tuple? [ + [ tuple-slots [ ] map ] [ class ] bi + read-only-slots >>slots + ] [ drop ] if ] if ; inline : init-value-info ( info -- info ) diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 1e221c89f1..89c2bada8b 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry assocs arrays byte-arrays strings accessors sequences kernel slots classes.algebra classes.tuple classes.tuple.private @@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths -! Revisit this code when delegation is removed and when complex -! numbers become tuples. - UNION: fixed-length-sequence array byte-array string ; : sequence-constructor? ( word -- ? ) diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor index 12baeb64b5..51e122431c 100644 --- a/core/generic/math/math-tests.factor +++ b/core/generic/math/math-tests.factor @@ -1,5 +1,5 @@ IN: generic.math.tests -USING: generic.math math tools.test ; +USING: generic.math math tools.test kernel ; ! Test math-combination [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test @@ -7,10 +7,15 @@ USING: generic.math math tools.test ; [ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test -[ number ] [ \ number \ float math-class-max ] unit-test -[ float ] [ \ real \ float math-class-max ] unit-test -[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test -[ bignum ] [ \ fixnum \ bignum math-class-max ] unit-test -[ number ] [ \ fixnum \ number math-class-max ] unit-test +[ number ] [ number float math-class-max ] unit-test +[ number ] [ float number math-class-max ] unit-test +[ float ] [ real float math-class-max ] unit-test +[ float ] [ float real math-class-max ] unit-test +[ fixnum ] [ fixnum null math-class-max ] unit-test +[ fixnum ] [ null fixnum math-class-max ] unit-test +[ bignum ] [ fixnum bignum math-class-max ] unit-test +[ bignum ] [ bignum fixnum math-class-max ] unit-test +[ number ] [ fixnum number math-class-max ] unit-test +[ number ] [ number fixnum math-class-max ] unit-test diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index f7e79e68bd..c96050ad03 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -22,11 +22,11 @@ PREDICATE: math-class < class : math-precedence ( class -- pair ) [ - { null fixnum bignum ratio float complex object } bootstrap-words - swap [ class<= ] curry find drop + { fixnum integer rational real number object } bootstrap-words + swap [ swap class<= ] curry find drop -1 or ] [ - { null fixnum integer rational real number object } bootstrap-words - swap [ swap class<= ] curry find drop + { fixnum bignum ratio float complex object } bootstrap-words + swap [ class<= ] curry find drop -1 or ] bi 2array ; : (math-upgrade) ( max class -- quot ) From 515c619202f9599a3a1616a89e6c341c265ab84d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 03:37:07 -0500 Subject: [PATCH 57/83] Non-optimizing compiler now open-codes megamorphic dispatch fast path --- basis/bootstrap/image/image.factor | 13 +++ basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/constants/constants.factor | 7 +- basis/cpu/x86/bootstrap.factor | 62 ++++++++---- core/bootstrap/primitives.factor | 6 +- core/generic/hook/hook.factor | 10 +- core/generic/single/single.factor | 28 ++--- core/generic/standard/standard.factor | 12 ++- vm/dispatch.c | 118 ++++++++++++---------- vm/dispatch.h | 8 +- vm/image.c | 2 +- vm/inline_cache.c | 3 +- vm/jit.c | 6 ++ vm/jit.h | 6 ++ vm/master.h | 2 +- vm/primitives.c | 3 +- vm/quotations.c | 21 +++- vm/run.h | 11 +- 18 files changed, 207 insertions(+), 113 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index a83b81d3f9..5bf3c30097 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -173,6 +173,11 @@ SYMBOL: pic-check SYMBOL: pic-hit SYMBOL: pic-miss-word +! Megamorphic dispatch +SYMBOL: mega-lookup +SYMBOL: mega-lookup-word +SYMBOL: mega-miss-word + ! Default definition for undefined words SYMBOL: undefined-quot @@ -215,6 +220,9 @@ SYMBOL: undefined-quot { pic-check 54 } { pic-hit 55 } { pic-miss-word 56 } + { mega-lookup 57 } + { mega-lookup-word 58 } + { mega-miss-word 59 } { undefined-quot 60 } } ; inline @@ -526,6 +534,8 @@ M: quotation ' \ 3dip jit-3dip-word set \ (execute) jit-execute-word set \ inline-cache-miss \ pic-miss-word set + \ mega-cache-lookup \ mega-lookup-word set + \ mega-cache-miss \ mega-miss-word set [ undefined ] undefined-quot set { jit-code-format @@ -563,6 +573,9 @@ M: quotation ' pic-check pic-hit pic-miss-word + mega-lookup + mega-lookup-word + mega-miss-word undefined-quot } [ emit-userenv ] each ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 2a0456e3b7..c19707a694 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -44,7 +44,7 @@ SYMBOL: calls SYMBOL: compiling-word -: compiled-stack-traces? ( -- ? ) 59 getenv ; +: compiled-stack-traces? ( -- ? ) 67 getenv ; ! Mapping _label IDs to label instances SYMBOL: labels diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index d384109cee..2f0494b58a 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel layouts system strings words quotations byte-arrays alien ; +USING: math kernel layouts system strings words quotations byte-arrays +alien arrays ; IN: compiler.constants ! These constants must match vm/memory.h @@ -20,8 +21,8 @@ CONSTANT: deck-bits 18 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline -: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline +: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline ! Relocation classes diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 325d86aa41..7efb4197c2 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -3,7 +3,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler layouts compiler.units math math.private compiler.constants vocabs slots.private words -locals.backend make sequences combinators ; +locals.backend make sequences combinators arrays ; IN: bootstrap.x86 big-endian off @@ -181,9 +181,11 @@ big-endian off ] pic-load jit-define ! Tag -[ +: load-tag ( -- ) temp1 tag-mask get AND -] pic-tag jit-define + temp1 tag-bits get SHL ; + +[ load-tag ] pic-tag jit-define ! The 'make' trick lets us compute the jump distance for the ! conditional branches there @@ -191,8 +193,8 @@ big-endian off ! Hi-tag [ temp0 temp1 MOV - temp1 tag-mask get AND - temp1 object tag-number CMP + load-tag + temp1 object tag-number tag-fixnum CMP [ temp1 temp0 object tag-number neg [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-hi-tag jit-define @@ -200,8 +202,8 @@ big-endian off ! Tuple [ temp0 temp1 MOV - temp1 tag-mask get AND - temp1 tuple tag-number CMP + load-tag + temp1 tuple tag-number tag-fixnum CMP [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-tuple jit-define @@ -209,21 +211,17 @@ big-endian off ! Hi-tag and tuple [ temp0 temp1 MOV - temp1 tag-mask get AND + load-tag ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) temp1 BIN: 110 tag-fixnum CMP [ - ! Untag temp0 in temp2 - temp2 temp0 MOV - temp2 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 1 for tuples - temp1 1 AND - bootstrap-cell { - { 4 [ temp1 2 SHR ] } - { 8 [ temp1 3 SHR ] } - } case + ! Untag temp0 + temp0 tag-mask get bitnot AND + ! Set temp1 to 0 for objects, and 8 for tuples + temp1 1 tag-fixnum AND + bootstrap-cell 4 = [ temp1 1 SHR ] when ! Load header cell or tuple layout cell - temp1 temp2 temp1 [+] MOV + temp1 temp0 temp1 [+] MOV ] [ ] make [ length JL ] [ % ] bi ] pic-hi-tag-tuple jit-define @@ -238,6 +236,34 @@ big-endian off [ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define +! ! ! Megamorphic caches + +[ + ! cache = ... + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel + ! key = class + temp2 temp1 MOV + ! compute cache.length - 1 + temp3 temp0 1 bootstrap-cells array tag-number - [+] MOV + temp3 1 SHR + temp3 4 SUB + ! key &= cache.length - 1 + temp2 temp3 AND + ! cache += array-start-offset + temp0 array-start-offset ADD + ! cache += key + temp0 temp2 ADD + ! if(get(cache) == class) + temp0 [] temp1 CMP + ! ... goto get(cache + bootstrap-cell) + [ + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP + ] [ ] make + [ length JNE ] [ % ] bi + ! fall-through on miss +] mega-lookup jit-define + ! ! ! Sub-primitives ! Quotations and words diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 2d2963c1d8..c0d51477ca 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -349,6 +349,7 @@ tuple { "get-local" "locals.backend" (( n -- obj )) } { "load-local" "locals.backend" (( obj -- )) } { "drop-locals" "locals.backend" (( n -- )) } + { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) } } [ first3 make-sub-primitive ] each ! Primitive words @@ -501,8 +502,9 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) } - { "inline-cache-miss" "generic.single.private" (( generic methods -- )) } + { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } { "reset-dispatch-stats" "generic.single" (( -- )) } { "dispatch-stats" "generic.single" (( -- stats )) } { "reset-inline-cache-stats" "generic.single" (( -- )) } diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index a44d071e4d..fe5b62f6c0 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors definitions generic generic.single kernel -namespaces words ; +USING: accessors definitions generic generic.single +generic.single.private kernel namespaces words kernel.private +quotations sequences ; IN: generic.hook TUPLE: hook-combination < single-combination var ; @@ -16,6 +17,11 @@ M: hook-combination picker M: hook-combination dispatch# drop 0 ; +M: hook-combination inline-cache-quot 2drop f ; + +M: hook-combination mega-cache-quot + 1quotation picker [ lookup-method (execute) ] surround ; + M: hook-generic definer drop \ HOOK: f ; M: hook-generic effective-method diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8e60b75bdc..4fe9ce5a36 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.algebra combinators definitions generic hashtables kernel -kernel.private layouts make math namespaces quotations +kernel.private layouts math namespaces quotations sequences words generic.single.private effects make ; IN: generic.single @@ -29,7 +29,7 @@ SYMBOL: combination HOOK: picker combination ( -- quot ) -M: single-combination next-method-quot* +M: single-combination next-method-quot* ( class generic combination -- quot ) [ 2dup next-method dup [ [ @@ -238,29 +238,19 @@ M: f compile-engine ; [ compile-engine ] bi ] tri ; -: make-empty-cache ( -- array ) - generic-word get "methods" word-prop - assoc-size 2 * next-power-of-2 f ; +HOOK: inline-cache-quot combination ( word methods -- quot/f ) -HOOK: direct-entry-def combination ( word methods -- quot/f ) +: define-inline-cache-quot ( word methods -- ) + [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ; -M: single-combination direct-entry-def 2drop f ; - -: define-direct-entry ( word methods -- ) - [ drop ] [ direct-entry-def ] 2bi >>direct-entry-def drop ; +HOOK: mega-cache-quot combination ( methods -- quot/f ) M: single-combination perform-combination [ dup generic-word set dup build-decision-tree [ "decision-tree" set-word-prop ] - [ - [ - picker % - , - make-empty-cache , - [ lookup-method (execute) ] % - ] [ ] make define - ] - [ define-direct-entry ] 2tri + [ mega-cache-quot define ] + [ define-inline-cache-quot ] + 2tri ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index e28ff677fa..5d26cfa6ff 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions generic generic.single kernel namespaces words math math.order combinators sequences -generic.single.private ; +generic.single.private quotations kernel.private +assocs arrays ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -39,12 +40,19 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; -M: standard-combination direct-entry-def ( word methods -- ) +M: standard-combination inline-cache-quot ( word methods -- ) #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. combination get #>> [ f inline-cache-miss ] 3curry [ ] like ; +: make-empty-cache ( -- array ) + generic-word get "methods" word-prop + assoc-size 2 * next-power-of-2 f ; + +M: standard-combination mega-cache-quot + combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ; + M: standard-generic definer drop \ GENERIC# f ; M: simple-generic definer drop \ GENERIC: f ; diff --git a/vm/dispatch.c b/vm/dispatch.c index 507725458e..68ef192531 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -81,30 +81,6 @@ static CELL lookup_hi_tag_method(CELL object, CELL methods) return array_nth(hi_tag_methods,tag); } -static CELL method_cache_hashcode(CELL key, F_ARRAY *array) -{ - CELL capacity = (array_capacity(array) >> 1) - 1; - return ((key >> TAG_BITS) & capacity) << 1; -} - -static CELL lookup_cached_method(CELL key, CELL method_cache) -{ - F_ARRAY *array = untag_object(method_cache); - CELL hashcode = method_cache_hashcode(key,array); - if(array_nth(array,hashcode) == key) - return array_nth(array,hashcode + 1); - else - return F; -} - -static void update_method_cache(CELL key, CELL method_cache, CELL method) -{ - F_ARRAY *array = untag_object(method_cache); - CELL hashcode = method_cache_hashcode(key,array); - set_array_nth(array,hashcode,key); - set_array_nth(array,hashcode + 1,method); -} - static CELL lookup_hairy_method(CELL object, CELL methods) { CELL method = array_nth(untag_object(methods),TAG(object)); @@ -127,43 +103,21 @@ static CELL lookup_hairy_method(CELL object, CELL methods) } } -static CELL lookup_method_with_cache(CELL object, CELL methods, CELL method_cache) +CELL lookup_method(CELL object, CELL methods) { if(!HI_TAG_OR_TUPLE_P(object)) - { - megamorphic_cache_hits++; return array_nth(untag_object(methods),TAG(object)); - } else - { - CELL key = get(HI_TAG_HEADER(object)); - CELL method = lookup_cached_method(key,method_cache); - if(method != F) - { - megamorphic_cache_hits++; - return method; - } - else - { - megamorphic_cache_misses++; - method = lookup_hairy_method(object,methods); - update_method_cache(key,method_cache,method); - return method; - } - } + return lookup_hairy_method(object,methods); } void primitive_lookup_method(void) { - CELL method_cache = get(ds); - CELL methods = get(ds - CELLS); - CELL object = get(ds - CELLS * 2); - ds -= CELLS * 2; - drepl(lookup_method_with_cache(object,methods,method_cache)); + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); } -/* Next two functions are used for polymorphic inline caching */ - CELL object_class(CELL object) { if(!HI_TAG_OR_TUPLE_P(object)) @@ -172,12 +126,35 @@ CELL object_class(CELL object) return get(HI_TAG_HEADER(object)); } -CELL lookup_method(CELL object, CELL methods) +static CELL method_cache_hashcode(CELL class, F_ARRAY *array) { - if(!HI_TAG_OR_TUPLE_P(object)) - return array_nth(untag_object(methods),TAG(object)); - else - return lookup_hairy_method(object,methods); + CELL capacity = (array_capacity(array) >> 1) - 1; + return ((class >> TAG_BITS) & capacity) << 1; +} + +static void update_method_cache(CELL cache, CELL class, CELL method) +{ + F_ARRAY *array = untag_object(cache); + CELL hashcode = method_cache_hashcode(class,array); + set_array_nth(array,hashcode,class); + set_array_nth(array,hashcode + 1,method); +} + +void primitive_mega_cache_miss(void) +{ + megamorphic_cache_misses++; + + CELL cache = dpop(); + F_FIXNUM index = untag_fixnum_fast(dpop()); + CELL methods = dpop(); + + CELL object = get(ds - index * CELLS); + CELL class = object_class(object); + CELL method = lookup_method(object,methods); + + update_method_cache(cache,class,method); + + dpush(method); } void primitive_reset_dispatch_stats(void) @@ -194,3 +171,32 @@ void primitive_dispatch_stats(void) GROWABLE_ARRAY_DONE(stats); dpush(stats); } + +void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type) +{ + jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); + jit_emit(jit,userenv[type]); +} + +void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache) +{ + /* Generate machine code to determine the object's class. */ + jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE); + + /* Do a cache lookup. */ + jit_emit_with(jit,userenv[MEGA_LOOKUP],cache); + + /* If we end up here, the cache missed. */ + jit_emit(jit,userenv[JIT_PROLOG]); + + /* Push index, method table and cache on the stack. */ + jit_push(jit,methods); + jit_push(jit,tag_fixnum(index)); + jit_push(jit,cache); + jit_word_call(jit,userenv[MEGA_MISS_WORD]); + + /* Now the new method has been stored into the cache, and its on + the stack. */ + jit_emit(jit,userenv[JIT_EPILOG]); + jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); +} diff --git a/vm/dispatch.h b/vm/dispatch.h index a05460dd7e..1aac242293 100644 --- a/vm/dispatch.h +++ b/vm/dispatch.h @@ -1,10 +1,16 @@ CELL megamorphic_cache_hits; CELL megamorphic_cache_misses; +CELL lookup_method(CELL object, CELL methods); void primitive_lookup_method(void); CELL object_class(CELL object); -CELL lookup_method(CELL object, CELL methods); + +void primitive_mega_cache_miss(void); void primitive_reset_dispatch_stats(void); void primitive_dispatch_stats(void); + +void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type); + +void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache); diff --git a/vm/image.c b/vm/image.c index 9cc97df0d9..d7bf035514 100755 --- a/vm/image.c +++ b/vm/image.c @@ -183,7 +183,7 @@ void primitive_save_image_and_exit(void) for(i = 0; i < FIRST_SAVE_ENV; i++) userenv[i] = F; - for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++) + for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++) userenv[i] = F; /* do a full GC + code heap compaction */ diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 4d10074ae6..8d1e16e01a 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -82,8 +82,7 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CEL jit_init(&jit,WORD_TYPE,generic_word); /* Generate machine code to determine the object's class. */ - jit_emit_with(&jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); - jit_emit(&jit,userenv[inline_cache_type]); + jit_emit_class_lookup(&jit,index,inline_cache_type); /* Generate machine code to check, in turn, if the class is one of the cached entries. */ CELL i; diff --git a/vm/jit.c b/vm/jit.c index 184cccf39f..8421b79468 100644 --- a/vm/jit.c +++ b/vm/jit.c @@ -1,5 +1,11 @@ #include "master.h" +/* Simple code generator used by: +- profiler (profiler.c), +- quotation compiler (quotations.c), +- megamorphic caches (dispatch.c), +- polymorphic inline caches (inline_cache.c) */ + /* Allocates memory */ void jit_init(F_JIT *jit, CELL jit_type, CELL owner) { diff --git a/vm/jit.h b/vm/jit.h index a8738eb835..0e27f2a7ab 100644 --- a/vm/jit.h +++ b/vm/jit.h @@ -45,6 +45,12 @@ INLINE void jit_word_jump(F_JIT *jit, CELL word) jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); } +/* Allocates memory */ +INLINE void jit_word_call(F_JIT *jit, CELL word) +{ + jit_emit_with(jit,userenv[JIT_WORD_CALL],word); +} + /* Allocates memory */ INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word) { diff --git a/vm/master.h b/vm/master.h index 83c2d39c0f..9866c4aafd 100644 --- a/vm/master.h +++ b/vm/master.h @@ -50,8 +50,8 @@ #include "callstack.h" #include "alien.h" #include "quotations.h" -#include "dispatch.h" #include "jit.h" +#include "dispatch.h" #include "inline_cache.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 61bc01a22e..cb5161693a 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -143,8 +143,9 @@ void *primitives[] = { primitive_jit_compile, primitive_load_locals, primitive_check_datastack, - primitive_lookup_method, primitive_inline_cache_miss, + primitive_mega_cache_miss, + primitive_lookup_method, primitive_reset_dispatch_stats, primitive_dispatch_stats, primitive_reset_inline_cache_stats, diff --git a/vm/quotations.c b/vm/quotations.c index 255289b407..0e24297ac1 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -89,6 +89,15 @@ static bool jit_ignore_declare_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; } +static bool jit_mega_lookup_p(F_ARRAY *array, CELL i) +{ + return (i + 3) < array_capacity(array) + && type_of(array_nth(array,i)) == ARRAY_TYPE + && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE + && type_of(array_nth(array,i + 2)) == ARRAY_TYPE + && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD]; +} + static bool jit_stack_frame_p(F_ARRAY *array) { F_FIXNUM length = array_capacity(array); @@ -189,7 +198,7 @@ void jit_compile(CELL quot, bool relocate) jit_word_jump(&jit,obj); } else - jit_emit_with(&jit,userenv[JIT_WORD_CALL],obj); + jit_word_call(&jit,obj); } break; case WRAPPER_TYPE: @@ -257,6 +266,16 @@ void jit_compile(CELL quot, bool relocate) i++; break; } + else if(jit_mega_lookup_p(untag_object(array),i)) + { + jit_emit_mega_cache_lookup(&jit, + array_nth(untag_object(array),i), + untag_fixnum_fast(array_nth(untag_object(array),i + 1)), + array_nth(untag_object(array),i + 2)); + i += 3; + tail_call = true; + break; + } default: jit_push(&jit,obj); break; diff --git a/vm/run.h b/vm/run.h index b8f27de5ae..e3e7aacf6f 100755 --- a/vm/run.h +++ b/vm/run.h @@ -32,7 +32,7 @@ typedef enum { BOOT_ENV = 20, /* boot quotation */ GLOBAL_ENV, /* global namespace */ - /* Used by the JIT compiler */ + /* Quotation compilation in quotations.c */ JIT_CODE_FORMAT = 22, JIT_PROLOG, JIT_PRIMITIVE_WORD, @@ -60,7 +60,7 @@ typedef enum { JIT_EXECUTE_JUMP, JIT_EXECUTE_CALL, - /* Used by polymorphic inline cache generation in inline_cache.c */ + /* Polymorphic inline cache generation in inline_cache.c */ PIC_LOAD = 48, PIC_TAG, PIC_HI_TAG, @@ -71,7 +71,10 @@ typedef enum { PIC_HIT, PIC_MISS_WORD, - STACK_TRACES_ENV = 59, + /* Megamorphic cache generation in dispatch.c */ + MEGA_LOOKUP = 57, + MEGA_LOOKUP_WORD, + MEGA_MISS_WORD, UNDEFINED_ENV = 60, /* default quotation for undefined words */ @@ -84,6 +87,8 @@ typedef enum { THREADS_ENV = 64, RUN_QUEUE_ENV = 65, SLEEP_QUEUE_ENV = 66, + + STACK_TRACES_ENV = 67, } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV From 8c01b79d06a8240ae3f94d6c030773e0a4caabc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 04:00:44 -0500 Subject: [PATCH 58/83] Fix PPC make-image --- basis/cpu/ppc/bootstrap.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 9e49916d81..199e8670c2 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -62,7 +62,7 @@ CONSTANT: rs-reg 30 [ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define -[ 0 B rc-relative-ppc-3 rt-xt ] jit-word-jump jit-define +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define [ 3 ds-reg 0 LWZ @@ -139,19 +139,19 @@ CONSTANT: rs-reg 30 [ jit->r - 0 BL rc-relative-ppc-3 rt-xt + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-r> ] jit-dip jit-define [ jit-2>r - 0 BL rc-relative-ppc-3 rt-xt + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-2r> ] jit-2dip jit-define [ jit-3>r - 0 BL rc-relative-ppc-3 rt-xt + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-3r> ] jit-3dip jit-define @@ -306,7 +306,7 @@ CONSTANT: rs-reg 30 ! Comparisons : jit-compare ( insn -- ) - 0 3 LOAD32 + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP @@ -315,8 +315,7 @@ CONSTANT: rs-reg 30 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip - define-sub-primitive ; + [ [ jit-compare ] curry ] dip define-sub-primitive ; \ BEQ \ eq? define-jit-compare \ BGE \ fixnum>= define-jit-compare From 1ce65acff170ab29218271b3c5bcff8f6336daff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 04:00:54 -0500 Subject: [PATCH 59/83] Benchmark harness now runs a GC first --- extra/benchmark/benchmark.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index ca48e6208c..220f16fad5 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger math namespaces ; +continuations debugger math namespaces memory ; IN: benchmark : run-benchmark ( vocab -- ) [ "=== " write vocab-name print flush ] [ - [ [ require ] [ [ run ] benchmark ] [ ] tri timings ] + [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ] [ swap errors ] recover get set-at ] bi ; From 59d6131c7c1667dddb19ed2f8422f84d45099b84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 04:14:14 -0500 Subject: [PATCH 60/83] Bum 3 instructions out of megamorphic fast path by switching to fixed-size caches --- basis/cpu/x86/bootstrap.factor | 6 +----- core/bootstrap/layouts/layouts.factor | 2 ++ core/generic/standard/standard.factor | 5 ++--- core/layouts/layouts.factor | 2 ++ 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 7efb4197c2..4f9a94a58b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -243,12 +243,8 @@ big-endian off temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! key = class temp2 temp1 MOV - ! compute cache.length - 1 - temp3 temp0 1 bootstrap-cells array tag-number - [+] MOV - temp3 1 SHR - temp3 4 SUB ! key &= cache.length - 1 - temp2 temp3 AND + temp2 mega-cache-size get 1- bootstrap-cell * AND ! cache += array-start-offset temp0 array-start-offset ADD ! cache += key diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 0243ad040e..5ed92b7776 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -11,6 +11,8 @@ BIN: 111 tag-mask set 15 num-types set +32 mega-cache-size set + H{ { fixnum BIN: 000 } { bignum BIN: 001 } diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5d26cfa6ff..96c273e3f8 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,7 +3,7 @@ USING: accessors definitions generic generic.single kernel namespaces words math math.order combinators sequences generic.single.private quotations kernel.private -assocs arrays ; +assocs arrays layouts ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -47,8 +47,7 @@ M: standard-combination inline-cache-quot ( word methods -- ) combination get #>> [ f inline-cache-miss ] 3curry [ ] like ; : make-empty-cache ( -- array ) - generic-word get "methods" word-prop - assoc-size 2 * next-power-of-2 f ; + mega-cache-size get f ; M: standard-combination mega-cache-quot combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index e30245abd1..00b9500211 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -16,6 +16,8 @@ SYMBOL: tag-numbers SYMBOL: type-numbers +SYMBOL: mega-cache-size + : type-number ( class -- n ) type-numbers get at ; From 5fb5c19d6191bebb2ab31927245492e666ebf9c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 04:34:35 -0500 Subject: [PATCH 61/83] Machine code is now stored in a byte array instead of an array for add_code_block() --- basis/bootstrap/image/image.factor | 5 +-- basis/compiler/codegen/fixup/fixup.factor | 6 ++-- basis/cpu/x86/bootstrap.factor | 2 -- vm/code_block.c | 43 ++++------------------- vm/code_block.h | 4 +-- vm/code_heap.c | 2 +- vm/jit.c | 14 ++++---- vm/jit.h | 5 ++- vm/quotations.c | 4 +-- vm/run.h | 3 +- 10 files changed, 22 insertions(+), 66 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 5bf3c30097..dde945e9af 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -111,7 +111,7 @@ SYMBOL: jit-define-offset jit-define-rc get jit-define-rt get jit-define-offset get 3array - ] { } make prefix ; + ] B{ } make prefix ; : jit-define ( quot name -- ) [ make-jit ] dip set ; @@ -135,7 +135,6 @@ SYMBOL: bootstrap-global SYMBOL: bootstrap-boot-quot ! JIT parameters -SYMBOL: jit-code-format SYMBOL: jit-prolog SYMBOL: jit-primitive-word SYMBOL: jit-primitive @@ -185,7 +184,6 @@ SYMBOL: undefined-quot H{ { bootstrap-boot-quot 20 } { bootstrap-global 21 } - { jit-code-format 22 } { jit-prolog 23 } { jit-primitive-word 24 } { jit-primitive 25 } @@ -538,7 +536,6 @@ M: quotation ' \ mega-cache-miss \ mega-miss-word set [ undefined ] undefined-quot set { - jit-code-format jit-prolog jit-primitive-word jit-primitive diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 45d87b3270..99f258d93c 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -9,9 +9,7 @@ IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) -: code-format ( -- n ) 22 getenv ; - -: compiled-offset ( -- n ) building get length code-format * ; +: compiled-offset ( -- n ) building get length ; SYMBOL: relocation-table SYMBOL: label-table @@ -91,4 +89,4 @@ SYMBOL: literal-table literal-table get >array relocation-table get >byte-array label-table get resolve-labels - ] { } make 4array ; + ] B{ } make 4array ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4f9a94a58b..f89839aa83 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -8,8 +8,6 @@ IN: bootstrap.x86 big-endian off -1 jit-code-format set - [ ! Load word temp0 0 MOV rc-absolute-cell rt-immediate jit-rel diff --git a/vm/code_block.c b/vm/code_block.c index 4331291083..1d428e4fcd 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -396,7 +396,7 @@ void relocate_code_block(F_CODE_BLOCK *compiled) } /* Fixup labels. This is done at compile time, not image load time */ -void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled) +void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled) { CELL i; CELL size = array_capacity(labels); @@ -413,31 +413,6 @@ void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled) } } -/* Write a sequence of integers to memory, with 'format' bytes per integer */ -void deposit_integers(CELL here, F_ARRAY *array, CELL format) -{ - CELL count = array_capacity(array); - CELL i; - - for(i = 0; i < count; i++) - { - F_FIXNUM value = to_fixnum(array_nth(array,i)); - if(format == 1) - bput(here + i,value); - else if(format == sizeof(unsigned int)) - *(unsigned int *)(here + format * i) = value; - else if(format == sizeof(CELL)) - *(CELL *)(here + format * i) = value; - else - critical_error("Bad format in deposit_integers()",format); - } -} - -CELL compiled_code_format(void) -{ - return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]); -} - /* Might GC */ F_CODE_BLOCK *allot_code_block(CELL size) { @@ -469,7 +444,7 @@ F_CODE_BLOCK *allot_code_block(CELL size) /* Might GC */ F_CODE_BLOCK *add_code_block( CELL type, - F_ARRAY *code, + F_BYTE_ARRAY *code, F_ARRAY *labels, CELL relocation, CELL literals) @@ -477,11 +452,10 @@ F_CODE_BLOCK *add_code_block( #ifdef FACTOR_DEBUG type_check(ARRAY_TYPE,literals); type_check(BYTE_ARRAY_TYPE,relocation); - assert(untag_header(code->header) == ARRAY_TYPE); + assert(untag_header(code->header) == BYTE_ARRAY_TYPE); #endif - CELL code_format = compiled_code_format(); - CELL code_length = align8(array_capacity(code) * code_format); + CELL code_length = align8(array_capacity(code)); REGISTER_ROOT(literals); REGISTER_ROOT(relocation); @@ -506,16 +480,11 @@ F_CODE_BLOCK *add_code_block( compiled->literals = literals; compiled->relocation = relocation; -#ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,compiled->literals); - type_check(BYTE_ARRAY_TYPE,compiled->relocation); -#endif - /* code */ - deposit_integers((CELL)(compiled + 1),code,code_format); + memcpy(compiled + 1,code + 1,code_length); /* fixup labels */ - if(labels) fixup_labels(labels,code_format,compiled); + if(labels) fixup_labels(labels,compiled); /* next time we do a minor GC, we have to scan the code heap for literals */ diff --git a/vm/code_block.h b/vm/code_block.h index b8201c44a1..385f414f88 100644 --- a/vm/code_block.h +++ b/vm/code_block.h @@ -79,8 +79,6 @@ void mark_object_code_block(CELL scan); void relocate_code_block(F_CODE_BLOCK *relocating); -CELL compiled_code_format(void); - INLINE bool stack_traces_p(void) { return userenv[STACK_TRACES_ENV] != F; @@ -88,7 +86,7 @@ INLINE bool stack_traces_p(void) F_CODE_BLOCK *add_code_block( CELL type, - F_ARRAY *code, + F_BYTE_ARRAY *code, F_ARRAY *labels, CELL relocation, CELL literals); diff --git a/vm/code_heap.c b/vm/code_heap.c index 0ae3d6b3fa..6ba98dfa77 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -93,7 +93,7 @@ void primitive_modify_code_heap(void) CELL literals = array_nth(compiled_code,0); CELL relocation = array_nth(compiled_code,1); F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); - F_ARRAY *code = untag_array(array_nth(compiled_code,3)); + F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3)); REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(word); diff --git a/vm/jit.c b/vm/jit.c index 8421b79468..8145d18b36 100644 --- a/vm/jit.c +++ b/vm/jit.c @@ -13,9 +13,8 @@ void jit_init(F_JIT *jit, CELL jit_type, CELL owner) REGISTER_ROOT(jit->owner); jit->type = jit_type; - jit->code_format = compiled_code_format(); - jit->code = make_growable_array(); + jit->code = make_growable_byte_array(); REGISTER_ROOT(jit->code.array); jit->relocation = make_growable_byte_array(); REGISTER_ROOT(jit->relocation.array); @@ -29,7 +28,7 @@ void jit_init(F_JIT *jit, CELL jit_type, CELL owner) /* Allocates memory */ F_CODE_BLOCK *jit_make_code_block(F_JIT *jit) { - growable_array_trim(&jit->code); + growable_byte_array_trim(&jit->code); growable_byte_array_trim(&jit->relocation); growable_array_trim(&jit->literals); @@ -66,9 +65,9 @@ static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p) else { *rel_p = true; - return (to_fixnum(rel_type) << 28) - | (to_fixnum(rel_class) << 24) - | ((jit->code.count + to_fixnum(offset)) * jit->code_format); + return (untag_fixnum_fast(rel_type) << 28) + | (untag_fixnum_fast(rel_class) << 24) + | ((jit->code.count + untag_fixnum_fast(offset))); } } @@ -79,7 +78,8 @@ void jit_emit(F_JIT *jit, CELL template) bool rel_p; F_REL rel = rel_to_emit(jit,template,&rel_p); if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); - growable_array_append(&jit->code,code_to_emit(template)); + F_BYTE_ARRAY *code = code_to_emit(template); + growable_byte_array_append(&jit->code,code + 1,array_capacity(code)); UNREGISTER_ROOT(template); } diff --git a/vm/jit.h b/vm/jit.h index 0e27f2a7ab..2085c8c8bd 100644 --- a/vm/jit.h +++ b/vm/jit.h @@ -1,8 +1,7 @@ typedef struct { CELL type; CELL owner; - CELL code_format; - F_GROWABLE_ARRAY code; + F_GROWABLE_BYTE_ARRAY code; F_GROWABLE_BYTE_ARRAY relocation; F_GROWABLE_ARRAY literals; } F_JIT; @@ -11,7 +10,7 @@ void jit_init(F_JIT *jit, CELL jit_type, CELL owner); F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); void jit_dispose(F_JIT *jit); -INLINE F_ARRAY *code_to_emit(CELL template) +INLINE F_BYTE_ARRAY *code_to_emit(CELL template) { return untag_object(array_nth(untag_object(template),0)); } diff --git a/vm/quotations.c b/vm/quotations.c index 0e24297ac1..d358a2c571 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -310,7 +310,7 @@ worse than the duplication itself (eg, putting all state in some global struct.) */ #define COUNT(name,scan) \ { \ - CELL size = array_capacity(code_to_emit(name)) * code_format; \ + CELL size = array_capacity(code_to_emit(name)); \ if(offset == 0) return scan - 1; \ if(offset < size) return scan + 1; \ offset -= size; \ @@ -324,8 +324,6 @@ struct.) */ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) { - CELL code_format = compiled_code_format(); - CELL array = untag_quotation(quot)->array; bool stack_frame = jit_stack_frame_p(untag_object(array)); diff --git a/vm/run.h b/vm/run.h index e3e7aacf6f..d32a91e67a 100755 --- a/vm/run.h +++ b/vm/run.h @@ -33,8 +33,7 @@ typedef enum { GLOBAL_ENV, /* global namespace */ /* Quotation compilation in quotations.c */ - JIT_CODE_FORMAT = 22, - JIT_PROLOG, + JIT_PROLOG = 23, JIT_PRIMITIVE_WORD, JIT_PRIMITIVE, JIT_WORD_JUMP, From 5bc63fc237c3bb470dd687695d77ef7621849591 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 05:59:44 -0500 Subject: [PATCH 62/83] At the end of a compilation unit, all PICs become dead so add them to the free list immediately instead of having them waste space until the next GC. Similarly, when a PIC transition occurs, add the old PIC to the free list immediately. Remove an unused function update_code_heap_roots() --- vm/code_block.c | 24 ++++++++++++++++++------ vm/code_gc.c | 13 ++++++++++--- vm/code_gc.h | 1 + vm/code_heap.c | 7 ------- vm/code_heap.h | 2 -- vm/cpu-x86.h | 13 ++++++++++++- vm/inline_cache.c | 26 ++++++++++++++++++++++++-- vm/layouts.h | 3 +++ 8 files changed, 68 insertions(+), 21 deletions(-) diff --git a/vm/code_block.c b/vm/code_block.c index 1d428e4fcd..f2ddc717f7 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -154,16 +154,16 @@ void copy_literal_references(F_CODE_BLOCK *compiled) CELL object_xt(CELL obj) { - if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - return (CELL)word->xt; - } - else + if(TAG(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); return (CELL)quot->xt; } + else + { + F_WORD *word = untag_object(obj); + return (CELL)word->xt; + } } CELL word_direct_xt(CELL obj) @@ -215,6 +215,18 @@ void update_word_references(F_CODE_BLOCK *compiled) { if(compiled->block.needs_fixup) relocate_code_block(compiled); + /* update_word_references() is always applied to every block in + the code heap. Since it resets all call sites to point to + their canonical XT (cold entry point for non-tail calls, + standard entry point for tail calls), it means that no PICs + are referenced after this is done. So instead of polluting + the code heap with dead PICs that will be freed on the next + GC, we add them to the free list immediately. */ + else if(compiled->block.type == PIC_TYPE) + { + fflush(stdout); + heap_free(&code_heap,&compiled->block); + } else { iterate_relocations(compiled,update_word_references_step); diff --git a/vm/code_gc.c b/vm/code_gc.c index e72c159375..c7ab02c6e6 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -17,7 +17,7 @@ void new_heap(F_HEAP *heap, CELL size) clear_free_list(heap); } -void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) +static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) { if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { @@ -94,7 +94,7 @@ static void assert_free_block(F_FREE_BLOCK *block) critical_error("Invalid block in free list",(CELL)block); } -F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) { CELL attempt = size; @@ -134,7 +134,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) return NULL; } -F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) { if(block->block.size != size ) { @@ -167,6 +167,13 @@ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) return NULL; } +/* Deallocates a block manually */ +void heap_free(F_HEAP *heap, F_BLOCK *block) +{ + block->status = B_FREE; + add_to_free_list(heap,(F_FREE_BLOCK *)block); +} + void mark_block(F_BLOCK *block) { /* If already marked, do nothing */ diff --git a/vm/code_gc.h b/vm/code_gc.h index d71dee29c5..35f8d66d90 100755 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -16,6 +16,7 @@ typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); void new_heap(F_HEAP *heap, CELL size); void build_free_list(F_HEAP *heap, CELL size); F_BLOCK *heap_allot(F_HEAP *heap, CELL size); +void heap_free(F_HEAP *heap, F_BLOCK *block); void mark_block(F_BLOCK *block); void unmark_marked(F_HEAP *heap); void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); diff --git a/vm/code_heap.c b/vm/code_heap.c index 6ba98dfa77..0a174903b6 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -47,13 +47,6 @@ void copy_code_heap_roots(void) iterate_code_heap(copy_literal_references); } -/* Update literals referenced from all code blocks. Only for tenured -collections, done at the end. */ -void update_code_heap_roots(void) -{ - iterate_code_heap(update_literal_and_word_references); -} - /* Update pointers to words referenced from all code blocks. Only after defining a new word. */ void update_code_heap_words(void) diff --git a/vm/code_heap.h b/vm/code_heap.h index b5e176d40c..01d282acfa 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -13,8 +13,6 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter); void copy_code_heap_roots(void); -void update_code_heap_roots(void); - void primitive_modify_code_heap(void); void primitive_code_room(void); diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index 9336b39de5..ab09893707 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -10,7 +10,7 @@ F_FASTCALL void lazy_jit_compile(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); -INLINE void set_call_site(CELL return_address, CELL target) +INLINE void check_call_site(CELL return_address) { /* An x86 CALL instruction looks like so: |e8|..|..|..|..| @@ -20,5 +20,16 @@ INLINE void set_call_site(CELL return_address, CELL target) #ifdef FACTOR_DEBUG assert(*(unsigned char *)(return_address - 5) == 0xe8); #endif +} + +INLINE CELL get_call_target(CELL return_address) +{ + check_call_site(return_address); + return *(F_FIXNUM *)(return_address - 4) + return_address; +} + +INLINE void set_call_target(CELL return_address, CELL target) +{ + check_call_site(return_address); *(F_FIXNUM *)(return_address - 4) = (target - return_address); } diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 8d1e16e01a..83981d2894 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -5,6 +5,23 @@ void init_inline_caching(int max_size) max_pic_size = max_size; } +void deallocate_inline_cache(CELL return_address) +{ + /* Find the call target. */ + XT old_xt = (XT)get_call_target(return_address); + F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1; + CELL old_type = old_block->block.type; + +#ifdef FACTOR_DEBUG + /* The call target was either another PIC, + or a compiled quotation (megamorphic stub) */ + assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE); +#endif + + if(old_type == PIC_TYPE) + heap_free(&code_heap,&old_block->block); +} + /* Figure out what kind of type check the PIC needs based on the methods it contains */ static CELL determine_inline_cache_type(CELL cache_entries) @@ -79,7 +96,7 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CEL update_pic_count(inline_cache_type); F_JIT jit; - jit_init(&jit,WORD_TYPE,generic_word); + jit_init(&jit,PIC_TYPE,generic_word); /* Generate machine code to determine the object's class. */ jit_emit_class_lookup(&jit,index,inline_cache_type); @@ -163,6 +180,11 @@ XT inline_cache_miss(CELL return_address) { check_code_pointer(return_address); + /* Since each PIC is only referenced from a single call site, + if the old call target was a PIC, we can deallocate it immediately, + instead of leaving dead PICs around until the next GC. */ + deallocate_inline_cache(return_address); + CELL cache_entries = dpop(); F_FIXNUM index = untag_fixnum_fast(dpop()); CELL methods = dpop(); @@ -195,7 +217,7 @@ XT inline_cache_miss(CELL return_address) } /* Install the new stub. */ - set_call_site(return_address,(CELL)xt); + set_call_target(return_address,(CELL)xt); #ifdef PIC_DEBUG printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt); diff --git a/vm/layouts.h b/vm/layouts.h index fd30f1bfa2..21a38165a7 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -60,6 +60,9 @@ typedef signed long long s64; #define TYPE_COUNT 15 +/* Not a real type, but F_CODE_BLOCK's type field can be set to this */ +#define PIC_TYPE 69 + INLINE bool immediate_p(CELL obj) { return (obj == F || TAG(obj) == FIXNUM_TYPE); From 4ae62691859fdb5a3be8045c8d71f40daa706d19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 05:59:59 -0500 Subject: [PATCH 63/83] PPC make-image fix --- basis/cpu/ppc/bootstrap.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 199e8670c2..1f86bf6a0d 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -9,8 +9,6 @@ IN: bootstrap.ppc 4 \ cell set big-endian on -4 jit-code-format set - CONSTANT: ds-reg 29 CONSTANT: rs-reg 30 From 5c9dc6d753be0b87e3d44c9466afb07f5b98c154 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 06:41:37 -0500 Subject: [PATCH 64/83] Tag-only PIC checks would always miss --- basis/cpu/x86/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index f89839aa83..fe5b85057d 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -224,7 +224,7 @@ big-endian off ] pic-hi-tag-tuple jit-define [ - temp1 HEX: ffffffff CMP rc-absolute rt-untagged jit-rel + temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel ] pic-check-tag jit-define [ From d6444e742ca52234a7a6705b5456325075bd73e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 07:06:23 -0500 Subject: [PATCH 65/83] Fix comment --- vm/layouts.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/layouts.h b/vm/layouts.h index 21a38165a7..f439b1f8a7 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -47,7 +47,7 @@ typedef signed long long s64; #define HEADER_TYPE 8 /* anything less than this is a tag */ -#define GC_COLLECTED 5 /* See gc.c */ +#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */ /*** Header types ***/ #define WRAPPER_TYPE 8 From 674bb9a4d57649193d491c03f892550eb0cd34db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 09:36:01 -0500 Subject: [PATCH 66/83] remove error_message from windows vm --- vm/os-windows.c | 34 ---------------------------------- vm/os-windows.h | 4 ---- 2 files changed, 38 deletions(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index 2abc04cb3b..c917cd804d 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -1,39 +1,5 @@ #include "master.h" -F_STRING *get_error_message(void) -{ - DWORD id = GetLastError(); - F_CHAR *msg = error_message(id); - F_STRING *string = from_u16_string(msg); - LocalFree(msg); - return string; -} - -/* You must LocalFree() the return value! */ -F_CHAR *error_message(DWORD id) -{ - F_CHAR *buffer; - int index; - - DWORD ret = FormatMessage( - FORMAT_MESSAGE_ALLOCATE_BUFFER | - FORMAT_MESSAGE_FROM_SYSTEM, - NULL, - id, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), - (LPTSTR)(void *) &buffer, - 0, NULL); - if(ret == 0) - return error_message(GetLastError()); - - /* strip whitespace from end */ - index = wcslen(buffer) - 1; - while(index >= 0 && isspace(buffer[index])) - buffer[index--] = 0; - - return buffer; -} - HMODULE hFactorDll; void init_ffi(void) diff --git a/vm/os-windows.h b/vm/os-windows.h index 36d350f50d..95d41ca9a2 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -42,10 +42,6 @@ typedef wchar_t F_CHAR; /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL -F_STRING *get_error_message(void); -DLLEXPORT F_CHAR *error_message(DWORD id); -void windows_error(void); - void init_ffi(void); void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); From 8ab4d3903611a9893ebd14b3c93cc9863b30ca0e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 09:36:25 -0500 Subject: [PATCH 67/83] move windows error handling to windows.errors and update usages. --- basis/calendar/windows/windows.factor | 4 +- basis/io/backend/windows/nt/nt.factor | 4 +- basis/io/backend/windows/windows.factor | 10 +- basis/io/files/windows/nt/nt.factor | 3 +- basis/io/monitors/windows/nt/nt.factor | 2 +- basis/random/windows/windows.factor | 4 +- basis/ui/backend/windows/windows.factor | 10 +- basis/windows/advapi32/advapi32.factor | 79 ++- basis/windows/errors/errors-tests.factor | 6 + basis/windows/errors/errors.factor | 760 ++++++++++++++++++++++- basis/windows/fonts/fonts.factor | 2 +- basis/windows/kernel32/kernel32.factor | 14 +- basis/windows/ole32/ole32.factor | 6 +- basis/windows/shell32/shell32.factor | 4 +- basis/windows/time/time.factor | 6 +- basis/windows/types/types.factor | 2 +- basis/windows/uniscribe/uniscribe.factor | 4 +- basis/windows/windows.factor | 56 -- basis/windows/winsock/winsock.factor | 4 +- 19 files changed, 858 insertions(+), 122 deletions(-) create mode 100755 basis/windows/errors/errors-tests.factor diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index 508cbb0a49..caab530a23 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: calendar namespaces alien.c-types system windows -windows.kernel32 kernel math combinators ; +USING: calendar namespaces alien.c-types system +windows.kernel32 kernel math combinators windows.errors ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 6f283ac1bb..46f8be22f0 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- ) { [ dup integer? ] [ ] } { [ dup array? ] [ first dup eof? - [ drop 0 ] [ (win32-error-string) throw ] if + [ drop 0 ] [ win32-error-string throw ] if ] } } cond ] with-timeout ; @@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- ) GetLastError { { [ dup expected-io-error? ] [ drop f ] } { [ dup eof? ] [ drop t ] } - [ (win32-error-string) throw ] + [ win32-error-string throw ] } cond ] [ f ] if ; diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 6ecbc49f2a..9f5c00cc5f 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.ports io.binary io.timeouts -windows.errors strings kernel math namespaces sequences windows -windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise system accessors ; +io.buffers io.files io.ports io.binary io.timeouts system +windows.errors strings kernel math namespaces sequences +windows.errors windows.kernel32 windows.shell32 windows.types +windows.winsock splitting continuations math.bitwise accessors ; IN: io.backend.windows : set-inherit ( handle ? -- ) @@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- ) : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" "SECURITY_ATTRIBUTES" heap-size - over set-SECURITY_ATTRIBUTES-nLength ; \ No newline at end of file + over set-SECURITY_ATTRIBUTES-nLength ; diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index afc81c784c..32424a37a3 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time windows.shell32 ; +namespaces make accessors tr windows.time windows.shell32 +windows.errors ; IN: io.files.windows.nt M: winnt cwd diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index d2408a3dd1..bec249c04c 100755 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.backend.windows io.backend.windows.nt io.files.windows.nt io.monitors io.ports io.buffers io.files io.timeouts io.encodings.string -io.encodings.utf16n io windows windows.kernel32 windows.types +io.encodings.utf16n io windows.errors windows.kernel32 windows.types io.pathnames ; IN: io.monitors.windows.nt diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index a4cf74e1df..488deef41f 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,6 +1,6 @@ USING: accessors alien.c-types byte-arrays continuations -kernel windows windows.advapi32 init namespaces random -destructors locals ; +kernel windows.advapi32 init namespaces random destructors +locals windows.errors ; IN: random.windows TUPLE: windows-rng provider type ; diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index e405efb540..42b80af8a9 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -6,15 +6,19 @@ ui.gadgets ui.gadgets.private ui.backend ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io kernel math math.vectors namespaces make sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 -windows.messages windows.types windows.offscreen windows.nt windows +windows.messages windows.types windows.offscreen windows.nt threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals accessors math.rectangles math.order ascii calendar -io.encodings.utf16n ; +io.encodings.utf16n windows.errors ; IN: ui.backend.windows SINGLETON: windows-ui-backend +: lo-word ( wparam -- lo ) *short ; inline +: hi-word ( wparam -- hi ) -16 shift lo-word ; inline +: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; + : crlf>lf ( str -- str' ) CHAR: \r swap remove ; @@ -286,8 +290,6 @@ SYMBOL: nc-buttons message>button nc-buttons get swap [ push ] [ delete ] if ; -: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; - : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ; : mouse-event>gesture ( uMsg -- button ) diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index 5b62f54795..f715af378b 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -350,35 +350,46 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_DEFAULT } flags ; foldable -CONSTANT: HKEY_CLASSES_ROOT 1 -CONSTANT: HKEY_CURRENT_CONFIG 2 -CONSTANT: HKEY_CURRENT_USER 3 -CONSTANT: HKEY_LOCAL_MACHINE 4 -CONSTANT: HKEY_USERS 5 +CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000 +CONSTANT: HKEY_CURRENT_USER HEX: 80000001 +CONSTANT: HKEY_LOCAL_MACHINE HEX: 80000002 +CONSTANT: HKEY_USERS HEX: 80000003 +CONSTANT: HKEY_PERFORMANCE_DATA HEX: 80000004 +CONSTANT: HKEY_CURRENT_CONFIG HEX: 80000005 +CONSTANT: HKEY_DYN_DATA HEX: 80000006 +CONSTANT: HKEY_PERFORMANCE_TEXT HEX: 80000050 +CONSTANT: HKEY_PERFORMANCE_NLSTEXT HEX: 80000060 -CONSTANT: KEY_ALL_ACCESS HEX: 0001 -CONSTANT: KEY_CREATE_LINK HEX: 0002 +CONSTANT: KEY_QUERY_VALUE HEX: 0001 +CONSTANT: KEY_SET_VALUE HEX: 0002 CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004 CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008 -CONSTANT: KEY_EXECUTE HEX: 0010 -CONSTANT: KEY_NOTIFY HEX: 0020 -CONSTANT: KEY_QUERY_VALUE HEX: 0040 -CONSTANT: KEY_READ HEX: 0080 -CONSTANT: KEY_SET_VALUE HEX: 0100 -CONSTANT: KEY_WOW64_64KEY HEX: 0200 -CONSTANT: KEY_WOW64_32KEY HEX: 0400 -CONSTANT: KEY_WRITE HEX: 0800 +CONSTANT: KEY_NOTIFY HEX: 0010 +CONSTANT: KEY_CREATE_LINK HEX: 0020 +CONSTANT: KEY_READ HEX: 20019 +CONSTANT: KEY_WOW64_32KEY HEX: 0200 +CONSTANT: KEY_WOW64_64KEY HEX: 0100 +CONSTANT: KEY_WRITE HEX: 20006 +CONSTANT: KEY_EXECUTE KEY_READ +CONSTANT: KEY_ALL_ACCESS HEX: F003F -CONSTANT: REG_BINARY 1 -CONSTANT: REG_DWORD 2 -CONSTANT: REG_EXPAND_SZ 3 -CONSTANT: REG_MULTI_SZ 4 -CONSTANT: REG_QWORD 5 -CONSTANT: REG_SZ 6 +CONSTANT: REG_NONE 0 +CONSTANT: REG_SZ 1 +CONSTANT: REG_EXPAND_SZ 2 +CONSTANT: REG_BINARY 3 +CONSTANT: REG_DWORD 4 +CONSTANT: REG_DWORD_LITTLE_ENDIAN 4 +CONSTANT: REG_DWORD_BIG_ENDIAN 5 +CONSTANT: REG_LINK 6 +CONSTANT: REG_MULTI_SZ 7 +CONSTANT: REG_RESOURCE_LIST 8 +CONSTANT: REG_FULL_RESOURCE_DESCRIPTOR 9 +CONSTANT: REG_RESOURCE_REQUIREMENTS_LIST 10 +CONSTANT: REG_QWORD 11 +CONSTANT: REG_QWORD_LITTLE_ENDIAN 11 TYPEDEF: DWORD REGSAM - ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; ! : A_SHAInit ; @@ -874,7 +885,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : ReadEncryptedFileRaw ; ! : ReadEventLogA ; ! : ReadEventLogW ; -! : RegCloseKey ; +FUNCTION: LONG RegCloseKey ( HKEY hKey ) ; ! : RegConnectRegistryA ; ! : RegConnectRegistryW ; ! : RegCreateKeyA ; @@ -900,17 +911,33 @@ FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LP FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ; ! : RegOpenKeyA ; ! : RegOpenKeyExA ; -! : RegOpenKeyExW ; +FUNCTION: LONG RegOpenKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD ulOptions, REGSAM samDesired, PHKEY phkResult ) ; +ALIAS: RegOpenKeyEx RegOpenKeyExW ! : RegOpenKeyW ; ! : RegOpenUserClassesRoot ; ! : RegOverridePredefKey ; ! : RegQueryInfoKeyA ; -! : RegQueryInfoKeyW ; +FUNCTION: LONG RegQueryInfoKeyW ( + HKEY hKey, + LPTSTR lpClass, + LPDWORD lpcClass, + LPDWORD lpReserved, + LPDWORD lpcSubKeys, + LPDWORD lpcMaxSubKeyLen, + LPDWORD lpcMaxClassLen, + LPDWORD lpcValues, + LPDWORD lpcMaxValueNameLen, + LPDWORD lpcMaxValueLen, + LPDWORD lpcbSecurityDescriptor, + PFILETIME lpftLastWriteTime + ) ; +ALIAS: RegQueryInfoKey RegQueryInfoKeyW ! : RegQueryMultipleValuesA ; ! : RegQueryMultipleValuesW ; ! : RegQueryValueA ; ! : RegQueryValueExA ; -FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; +FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; +ALIAS: RegQueryValueEx RegQueryValueExW ! : RegQueryValueW ; ! : RegReplaceKeyA ; ! : RegReplaceKeyW ; diff --git a/basis/windows/errors/errors-tests.factor b/basis/windows/errors/errors-tests.factor new file mode 100755 index 0000000000..96edb8a379 --- /dev/null +++ b/basis/windows/errors/errors-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test windows.errors strings ; +IN: windows.errors.tests + +[ t ] [ 0 n>win32-error-string string? ] unit-test diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 56bba768de..34fd019889 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,9 +1,753 @@ -IN: windows.errors +USING: alien.c-types kernel locals math math.bitwise +windows.kernel32 sequences byte-arrays unicode.categories +io.encodings.string io.encodings.utf16n alien.strings ; +IN: windows.errors -CONSTANT: ERROR_SUCCESS 0 -CONSTANT: ERROR_NO_MORE_FILES 18 -CONSTANT: ERROR_HANDLE_EOF 38 -CONSTANT: ERROR_BROKEN_PIPE 109 -CONSTANT: ERROR_ENVVAR_NOT_FOUND 203 -CONSTANT: ERROR_IO_INCOMPLETE 996 -CONSTANT: ERROR_IO_PENDING 997 +CONSTANT: ERROR_SUCCESS 0 +CONSTANT: ERROR_INVALID_FUNCTION 1 +CONSTANT: ERROR_FILE_NOT_FOUND 2 +CONSTANT: ERROR_PATH_NOT_FOUND 3 +CONSTANT: ERROR_TOO_MANY_OPEN_FILES 4 +CONSTANT: ERROR_ACCESS_DENIED 5 +CONSTANT: ERROR_INVALID_HANDLE 6 +CONSTANT: ERROR_ARENA_TRASHED 7 +CONSTANT: ERROR_NOT_ENOUGH_MEMORY 8 +CONSTANT: ERROR_INVALID_BLOCK 9 +CONSTANT: ERROR_BAD_ENVIRONMENT 10 +CONSTANT: ERROR_BAD_FORMAT 11 +CONSTANT: ERROR_INVALID_ACCESS 12 +CONSTANT: ERROR_INVALID_DATA 13 +CONSTANT: ERROR_OUTOFMEMORY 14 +CONSTANT: ERROR_INVALID_DRIVE 15 +CONSTANT: ERROR_CURRENT_DIRECTORY 16 +CONSTANT: ERROR_NOT_SAME_DEVICE 17 +CONSTANT: ERROR_NO_MORE_FILES 18 +CONSTANT: ERROR_WRITE_PROTECT 19 +CONSTANT: ERROR_BAD_UNIT 20 +CONSTANT: ERROR_NOT_READY 21 +CONSTANT: ERROR_BAD_COMMAND 22 +CONSTANT: ERROR_CRC 23 +CONSTANT: ERROR_BAD_LENGTH 24 +CONSTANT: ERROR_SEEK 25 +CONSTANT: ERROR_NOT_DOS_DISK 26 +CONSTANT: ERROR_SECTOR_NOT_FOUND 27 +CONSTANT: ERROR_OUT_OF_PAPER 28 +CONSTANT: ERROR_WRITE_FAULT 29 +CONSTANT: ERROR_READ_FAULT 30 +CONSTANT: ERROR_GEN_FAILURE 31 +CONSTANT: ERROR_SHARING_VIOLATION 32 +CONSTANT: ERROR_LOCK_VIOLATION 33 +CONSTANT: ERROR_WRONG_DISK 34 +CONSTANT: ERROR_SHARING_BUFFER_EXCEEDED 36 +CONSTANT: ERROR_HANDLE_EOF 38 +CONSTANT: ERROR_HANDLE_DISK_FULL 39 +CONSTANT: ERROR_NOT_SUPPORTED 50 +CONSTANT: ERROR_REM_NOT_LIST 51 +CONSTANT: ERROR_DUP_NAME 52 +CONSTANT: ERROR_BAD_NETPATH 53 +CONSTANT: ERROR_NETWORK_BUSY 54 +CONSTANT: ERROR_DEV_NOT_EXIST 55 +CONSTANT: ERROR_TOO_MANY_CMDS 56 +CONSTANT: ERROR_ADAP_HDW_ERR 57 +CONSTANT: ERROR_BAD_NET_RESP 58 +CONSTANT: ERROR_UNEXP_NET_ERR 59 +CONSTANT: ERROR_BAD_REM_ADAP 60 +CONSTANT: ERROR_PRINTQ_FULL 61 +CONSTANT: ERROR_NO_SPOOL_SPACE 62 +CONSTANT: ERROR_PRINT_CANCELLED 63 +CONSTANT: ERROR_NETNAME_DELETED 64 +CONSTANT: ERROR_NETWORK_ACCESS_DENIED 65 +CONSTANT: ERROR_BAD_DEV_TYPE 66 +CONSTANT: ERROR_BAD_NET_NAME 67 +CONSTANT: ERROR_TOO_MANY_NAMES 68 +CONSTANT: ERROR_TOO_MANY_SESS 69 +CONSTANT: ERROR_SHARING_PAUSED 70 +CONSTANT: ERROR_REQ_NOT_ACCEP 71 +CONSTANT: ERROR_REDIR_PAUSED 72 +CONSTANT: ERROR_FILE_EXISTS 80 +CONSTANT: ERROR_CANNOT_MAKE 82 +CONSTANT: ERROR_FAIL_I24 83 +CONSTANT: ERROR_OUT_OF_STRUCTURES 84 +CONSTANT: ERROR_ALREADY_ASSIGNED 85 +CONSTANT: ERROR_INVALID_PASSWORD 86 +CONSTANT: ERROR_INVALID_PARAMETER 87 +CONSTANT: ERROR_NET_WRITE_FAULT 88 +CONSTANT: ERROR_NO_PROC_SLOTS 89 +CONSTANT: ERROR_TOO_MANY_SEMAPHORES 100 +CONSTANT: ERROR_EXCL_SEM_ALREADY_OWNED 101 +CONSTANT: ERROR_SEM_IS_SET 102 +CONSTANT: ERROR_TOO_MANY_SEM_REQUESTS 103 +CONSTANT: ERROR_INVALID_AT_INTERRUPT_TIME 104 +CONSTANT: ERROR_SEM_OWNER_DIED 105 +CONSTANT: ERROR_SEM_USER_LIMIT 106 +CONSTANT: ERROR_DISK_CHANGE 107 +CONSTANT: ERROR_DRIVE_LOCKED 108 +CONSTANT: ERROR_BROKEN_PIPE 109 +CONSTANT: ERROR_OPEN_FAILED 110 +CONSTANT: ERROR_BUFFER_OVERFLOW 111 +CONSTANT: ERROR_DISK_FULL 112 +CONSTANT: ERROR_NO_MORE_SEARCH_HANDLES 113 +CONSTANT: ERROR_INVALID_TARGET_HANDLE 114 +CONSTANT: ERROR_INVALID_CATEGORY 117 +CONSTANT: ERROR_INVALID_VERIFY_SWITCH 118 +CONSTANT: ERROR_BAD_DRIVER_LEVEL 119 +CONSTANT: ERROR_CALL_NOT_IMPLEMENTED 120 +CONSTANT: ERROR_SEM_TIMEOUT 121 +CONSTANT: ERROR_INSUFFICIENT_BUFFER 122 +CONSTANT: ERROR_INVALID_NAME 123 +CONSTANT: ERROR_INVALID_LEVEL 124 +CONSTANT: ERROR_NO_VOLUME_LABEL 125 +CONSTANT: ERROR_MOD_NOT_FOUND 126 +CONSTANT: ERROR_PROC_NOT_FOUND 127 +CONSTANT: ERROR_WAIT_NO_CHILDREN 128 +CONSTANT: ERROR_CHILD_NOT_COMPLETE 129 +CONSTANT: ERROR_DIRECT_ACCESS_HANDLE 130 +CONSTANT: ERROR_NEGATIVE_SEEK 131 +CONSTANT: ERROR_SEEK_ON_DEVICE 132 +CONSTANT: ERROR_IS_JOIN_TARGET 133 +CONSTANT: ERROR_IS_JOINED 134 +CONSTANT: ERROR_IS_SUBSTED 135 +CONSTANT: ERROR_NOT_JOINED 136 +CONSTANT: ERROR_NOT_SUBSTED 137 +CONSTANT: ERROR_JOIN_TO_JOIN 138 +CONSTANT: ERROR_SUBST_TO_SUBST 139 +CONSTANT: ERROR_JOIN_TO_SUBST 140 +CONSTANT: ERROR_SUBST_TO_JOIN 141 +CONSTANT: ERROR_BUSY_DRIVE 142 +CONSTANT: ERROR_SAME_DRIVE 143 +CONSTANT: ERROR_DIR_NOT_ROOT 144 +CONSTANT: ERROR_DIR_NOT_EMPTY 145 +CONSTANT: ERROR_IS_SUBST_PATH 146 +CONSTANT: ERROR_IS_JOIN_PATH 147 +CONSTANT: ERROR_PATH_BUSY 148 +CONSTANT: ERROR_IS_SUBST_TARGET 149 +CONSTANT: ERROR_SYSTEM_TRACE 150 +CONSTANT: ERROR_INVALID_EVENT_COUNT 151 +CONSTANT: ERROR_TOO_MANY_MUXWAITERS 152 +CONSTANT: ERROR_INVALID_LIST_FORMAT 153 +CONSTANT: ERROR_LABEL_TOO_LONG 154 +CONSTANT: ERROR_TOO_MANY_TCBS 155 +CONSTANT: ERROR_SIGNAL_REFUSED 156 +CONSTANT: ERROR_DISCARDED 157 +CONSTANT: ERROR_NOT_LOCKED 158 +CONSTANT: ERROR_BAD_THREADID_ADDR 159 +CONSTANT: ERROR_BAD_ARGUMENTS 160 +CONSTANT: ERROR_BAD_PATHNAME 161 +CONSTANT: ERROR_SIGNAL_PENDING 162 +CONSTANT: ERROR_MAX_THRDS_REACHED 164 +CONSTANT: ERROR_LOCK_FAILED 167 +CONSTANT: ERROR_BUSY 170 +CONSTANT: ERROR_CANCEL_VIOLATION 173 +CONSTANT: ERROR_ATOMIC_LOCKS_NOT_SUPPORTED 174 +CONSTANT: ERROR_INVALID_SEGMENT_NUMBER 180 +CONSTANT: ERROR_INVALID_ORDINAL 182 +CONSTANT: ERROR_ALREADY_EXISTS 183 +CONSTANT: ERROR_INVALID_FLAG_NUMBER 186 +CONSTANT: ERROR_SEM_NOT_FOUND 187 +CONSTANT: ERROR_INVALID_STARTING_CODESEG 188 +CONSTANT: ERROR_INVALID_STACKSEG 189 +CONSTANT: ERROR_INVALID_MODULETYPE 190 +CONSTANT: ERROR_INVALID_EXE_SIGNATURE 191 +CONSTANT: ERROR_EXE_MARKED_INVALID 192 +CONSTANT: ERROR_BAD_EXE_FORMAT 193 +CONSTANT: ERROR_ITERATED_DATA_EXCEEDS_64k 194 +CONSTANT: ERROR_INVALID_MINALLOCSIZE 195 +CONSTANT: ERROR_DYNLINK_FROM_INVALID_RING 196 +CONSTANT: ERROR_IOPL_NOT_ENABLED 197 +CONSTANT: ERROR_INVALID_SEGDPL 198 +CONSTANT: ERROR_AUTODATASEG_EXCEEDS_64k 199 +CONSTANT: ERROR_RING2SEG_MUST_BE_MOVABLE 200 +CONSTANT: ERROR_RELOC_CHAIN_XEEDS_SEGLIM 201 +CONSTANT: ERROR_INFLOOP_IN_RELOC_CHAIN 202 +CONSTANT: ERROR_ENVVAR_NOT_FOUND 203 +CONSTANT: ERROR_NO_SIGNAL_SENT 205 +CONSTANT: ERROR_FILENAME_EXCED_RANGE 206 +CONSTANT: ERROR_RING2_STACK_IN_USE 207 +CONSTANT: ERROR_META_EXPANSION_TOO_LONG 208 +CONSTANT: ERROR_INVALID_SIGNAL_NUMBER 209 +CONSTANT: ERROR_THREAD_1_INACTIVE 210 +CONSTANT: ERROR_LOCKED 212 +CONSTANT: ERROR_TOO_MANY_MODULES 214 +CONSTANT: ERROR_NESTING_NOT_ALLOWED 215 +CONSTANT: ERROR_EXE_MACHINE_TYPE_MISMATCH 216 +CONSTANT: ERROR_BAD_PIPE 230 +CONSTANT: ERROR_PIPE_BUSY 231 +CONSTANT: ERROR_NO_DATA 232 +CONSTANT: ERROR_PIPE_NOT_CONNECTED 233 +CONSTANT: ERROR_MORE_DATA 234 +CONSTANT: ERROR_VC_DISCONNECTED 240 +CONSTANT: ERROR_INVALID_EA_NAME 254 +CONSTANT: ERROR_EA_LIST_INCONSISTENT 255 +CONSTANT: ERROR_NO_MORE_ITEMS 259 +CONSTANT: ERROR_CANNOT_COPY 266 +CONSTANT: ERROR_DIRECTORY 267 +CONSTANT: ERROR_EAS_DIDNT_FIT 275 +CONSTANT: ERROR_EA_FILE_CORRUPT 276 +CONSTANT: ERROR_EA_TABLE_FULL 277 +CONSTANT: ERROR_INVALID_EA_HANDLE 278 +CONSTANT: ERROR_EAS_NOT_SUPPORTED 282 +CONSTANT: ERROR_NOT_OWNER 288 +CONSTANT: ERROR_TOO_MANY_POSTS 298 +CONSTANT: ERROR_PARTIAL_COPY 299 +CONSTANT: ERROR_MR_MID_NOT_FOUND 317 +CONSTANT: ERROR_INVALID_ADDRESS 487 +CONSTANT: ERROR_ARITHMETIC_OVERFLOW 534 +CONSTANT: ERROR_PIPE_CONNECTED 535 +CONSTANT: ERROR_PIPE_LISTENING 536 +CONSTANT: ERROR_EA_ACCESS_DENIED 994 +CONSTANT: ERROR_OPERATION_ABORTED 995 +CONSTANT: ERROR_IO_INCOMPLETE 996 +CONSTANT: ERROR_IO_PENDING 997 +CONSTANT: ERROR_NOACCESS 998 +CONSTANT: ERROR_SWAPERROR 999 +CONSTANT: ERROR_STACK_OVERFLOW 1001 +CONSTANT: ERROR_INVALID_MESSAGE 1002 +CONSTANT: ERROR_CAN_NOT_COMPLETE 1003 +CONSTANT: ERROR_INVALID_FLAGS 1004 +CONSTANT: ERROR_UNRECOGNIZED_VOLUME 1005 +CONSTANT: ERROR_FILE_INVALID 1006 +CONSTANT: ERROR_FULLSCREEN_MODE 1007 +CONSTANT: ERROR_NO_TOKEN 1008 +CONSTANT: ERROR_BADDB 1009 +CONSTANT: ERROR_BADKEY 1010 +CONSTANT: ERROR_CANTOPEN 1011 +CONSTANT: ERROR_CANTREAD 1012 +CONSTANT: ERROR_CANTWRITE 1013 +CONSTANT: ERROR_REGISTRY_RECOVERED 1014 +CONSTANT: ERROR_REGISTRY_CORRUPT 1015 +CONSTANT: ERROR_REGISTRY_IO_FAILED 1016 +CONSTANT: ERROR_NOT_REGISTRY_FILE 1017 +CONSTANT: ERROR_KEY_DELETED 1018 +CONSTANT: ERROR_NO_LOG_SPACE 1019 +CONSTANT: ERROR_KEY_HAS_CHILDREN 1020 +CONSTANT: ERROR_CHILD_MUST_BE_VOLATILE 1021 +CONSTANT: ERROR_NOTIFY_ENUM_DIR 1022 +CONSTANT: ERROR_DEPENDENT_SERVICES_RUNNING 1051 +CONSTANT: ERROR_INVALID_SERVICE_CONTROL 1052 +CONSTANT: ERROR_SERVICE_REQUEST_TIMEOUT 1053 +CONSTANT: ERROR_SERVICE_NO_THREAD 1054 +CONSTANT: ERROR_SERVICE_DATABASE_LOCKED 1055 +CONSTANT: ERROR_SERVICE_ALREADY_RUNNING 1056 +CONSTANT: ERROR_INVALID_SERVICE_ACCOUNT 1057 +CONSTANT: ERROR_SERVICE_DISABLED 1058 +CONSTANT: ERROR_CIRCULAR_DEPENDENCY 1059 +CONSTANT: ERROR_SERVICE_DOES_NOT_EXIST 1060 +CONSTANT: ERROR_SERVICE_CANNOT_ACCEPT_CTRL 1061 +CONSTANT: ERROR_SERVICE_NOT_ACTIVE 1062 +CONSTANT: ERROR_FAILED_SERVICE_CONTROLLER_CONNECT 1063 +CONSTANT: ERROR_EXCEPTION_IN_SERVICE 1064 +CONSTANT: ERROR_DATABASE_DOES_NOT_EXIST 1065 +CONSTANT: ERROR_SERVICE_SPECIFIC_ERROR 1066 +CONSTANT: ERROR_PROCESS_ABORTED 1067 +CONSTANT: ERROR_SERVICE_DEPENDENCY_FAIL 1068 +CONSTANT: ERROR_SERVICE_LOGON_FAILED 1069 +CONSTANT: ERROR_SERVICE_START_HANG 1070 +CONSTANT: ERROR_INVALID_SERVICE_LOCK 1071 +CONSTANT: ERROR_SERVICE_MARKED_FOR_DELETE 1072 +CONSTANT: ERROR_SERVICE_EXISTS 1073 +CONSTANT: ERROR_ALREADY_RUNNING_LKG 1074 +CONSTANT: ERROR_SERVICE_DEPENDENCY_DELETED 1075 +CONSTANT: ERROR_BOOT_ALREADY_ACCEPTED 1076 +CONSTANT: ERROR_SERVICE_NEVER_STARTED 1077 +CONSTANT: ERROR_DUPLICATE_SERVICE_NAME 1078 +CONSTANT: ERROR_DIFFERENT_SERVICE_ACCOUNT 1079 +CONSTANT: ERROR_END_OF_MEDIA 1100 +CONSTANT: ERROR_FILEMARK_DETECTED 1101 +CONSTANT: ERROR_BEGINNING_OF_MEDIA 1102 +CONSTANT: ERROR_SETMARK_DETECTED 1103 +CONSTANT: ERROR_NO_DATA_DETECTED 1104 +CONSTANT: ERROR_PARTITION_FAILURE 1105 +CONSTANT: ERROR_INVALID_BLOCK_LENGTH 1106 +CONSTANT: ERROR_DEVICE_NOT_PARTITIONED 1107 +CONSTANT: ERROR_UNABLE_TO_LOCK_MEDIA 1108 +CONSTANT: ERROR_UNABLE_TO_UNLOAD_MEDIA 1109 +CONSTANT: ERROR_MEDIA_CHANGED 1110 +CONSTANT: ERROR_BUS_RESET 1111 +CONSTANT: ERROR_NO_MEDIA_IN_DRIVE 1112 +CONSTANT: ERROR_NO_UNICODE_TRANSLATION 1113 +CONSTANT: ERROR_DLL_INIT_FAILED 1114 +CONSTANT: ERROR_SHUTDOWN_IN_PROGRESS 1115 +CONSTANT: ERROR_NO_SHUTDOWN_IN_PROGRESS 1116 +CONSTANT: ERROR_IO_DEVICE 1117 +CONSTANT: ERROR_SERIAL_NO_DEVICE 1118 +CONSTANT: ERROR_IRQ_BUSY 1119 +CONSTANT: ERROR_MORE_WRITES 1120 +CONSTANT: ERROR_COUNTER_TIMEOUT 1121 +CONSTANT: ERROR_FLOPPY_ID_MARK_NOT_FOUND 1122 +CONSTANT: ERROR_FLOPPY_WRONG_CYLINDER 1123 +CONSTANT: ERROR_FLOPPY_UNKNOWN_ERROR 1124 +CONSTANT: ERROR_FLOPPY_BAD_REGISTERS 1125 +CONSTANT: ERROR_DISK_RECALIBRATE_FAILED 1126 +CONSTANT: ERROR_DISK_OPERATION_FAILED 1127 +CONSTANT: ERROR_DISK_RESET_FAILED 1128 +CONSTANT: ERROR_EOM_OVERFLOW 1129 +CONSTANT: ERROR_NOT_ENOUGH_SERVER_MEMORY 1130 +CONSTANT: ERROR_POSSIBLE_DEADLOCK 1131 +CONSTANT: ERROR_MAPPED_ALIGNMENT 1132 +CONSTANT: ERROR_SET_POWER_STATE_VETOED 1140 +CONSTANT: ERROR_SET_POWER_STATE_FAILED 1141 +CONSTANT: ERROR_TOO_MANY_LINKS 1142 +CONSTANT: ERROR_OLD_WIN_VERSION 1150 +CONSTANT: ERROR_APP_WRONG_OS 1151 +CONSTANT: ERROR_SINGLE_INSTANCE_APP 1152 +CONSTANT: ERROR_RMODE_APP 1153 +CONSTANT: ERROR_INVALID_DLL 1154 +CONSTANT: ERROR_NO_ASSOCIATION 1155 +CONSTANT: ERROR_DDE_FAIL 1156 +CONSTANT: ERROR_DLL_NOT_FOUND 1157 +CONSTANT: ERROR_BAD_DEVICE 1200 +CONSTANT: ERROR_CONNECTION_UNAVAIL 1201 +CONSTANT: ERROR_DEVICE_ALREADY_REMEMBERED 1202 +CONSTANT: ERROR_NO_NET_OR_BAD_PATH 1203 +CONSTANT: ERROR_BAD_PROVIDER 1204 +CONSTANT: ERROR_CANNOT_OPEN_PROFILE 1205 +CONSTANT: ERROR_BAD_PROFILE 1206 +CONSTANT: ERROR_NOT_CONTAINER 1207 +CONSTANT: ERROR_EXTENDED_ERROR 1208 +CONSTANT: ERROR_INVALID_GROUPNAME 1209 +CONSTANT: ERROR_INVALID_COMPUTERNAME 1210 +CONSTANT: ERROR_INVALID_EVENTNAME 1211 +CONSTANT: ERROR_INVALID_DOMAINNAME 1212 +CONSTANT: ERROR_INVALID_SERVICENAME 1213 +CONSTANT: ERROR_INVALID_NETNAME 1214 +CONSTANT: ERROR_INVALID_SHARENAME 1215 +CONSTANT: ERROR_INVALID_PASSWORDNAME 1216 +CONSTANT: ERROR_INVALID_MESSAGENAME 1217 +CONSTANT: ERROR_INVALID_MESSAGEDEST 1218 +CONSTANT: ERROR_SESSION_CREDENTIAL_CONFLICT 1219 +CONSTANT: ERROR_REMOTE_SESSION_LIMIT_EXCEEDED 1220 +CONSTANT: ERROR_DUP_DOMAINNAME 1221 +CONSTANT: ERROR_NO_NETWORK 1222 +CONSTANT: ERROR_CANCELLED 1223 +CONSTANT: ERROR_USER_MAPPED_FILE 1224 +CONSTANT: ERROR_CONNECTION_REFUSED 1225 +CONSTANT: ERROR_GRACEFUL_DISCONNECT 1226 +CONSTANT: ERROR_ADDRESS_ALREADY_ASSOCIATED 1227 +CONSTANT: ERROR_ADDRESS_NOT_ASSOCIATED 1228 +CONSTANT: ERROR_CONNECTION_INVALID 1229 +CONSTANT: ERROR_CONNECTION_ACTIVE 1230 +CONSTANT: ERROR_NETWORK_UNREACHABLE 1231 +CONSTANT: ERROR_HOST_UNREACHABLE 1232 +CONSTANT: ERROR_PROTOCOL_UNREACHABLE 1233 +CONSTANT: ERROR_PORT_UNREACHABLE 1234 +CONSTANT: ERROR_REQUEST_ABORTED 1235 +CONSTANT: ERROR_CONNECTION_ABORTED 1236 +CONSTANT: ERROR_RETRY 1237 +CONSTANT: ERROR_CONNECTION_COUNT_LIMIT 1238 +CONSTANT: ERROR_LOGIN_TIME_RESTRICTION 1239 +CONSTANT: ERROR_LOGIN_WKSTA_RESTRICTION 1240 +CONSTANT: ERROR_INCORRECT_ADDRESS 1241 +CONSTANT: ERROR_ALREADY_REGISTERED 1242 +CONSTANT: ERROR_SERVICE_NOT_FOUND 1243 +CONSTANT: ERROR_NOT_AUTHENTICATED 1244 +CONSTANT: ERROR_NOT_LOGGED_ON 1245 +CONSTANT: ERROR_CONTINUE 1246 +CONSTANT: ERROR_ALREADY_INITIALIZED 1247 +CONSTANT: ERROR_NO_MORE_DEVICES 1248 +CONSTANT: ERROR_NOT_ALL_ASSIGNED 1300 +CONSTANT: ERROR_SOME_NOT_MAPPED 1301 +CONSTANT: ERROR_NO_QUOTAS_FOR_ACCOUNT 1302 +CONSTANT: ERROR_LOCAL_USER_SESSION_KEY 1303 +CONSTANT: ERROR_NULL_LM_PASSWORD 1304 +CONSTANT: ERROR_UNKNOWN_REVISION 1305 +CONSTANT: ERROR_REVISION_MISMATCH 1306 +CONSTANT: ERROR_INVALID_OWNER 1307 +CONSTANT: ERROR_INVALID_PRIMARY_GROUP 1308 +CONSTANT: ERROR_NO_IMPERSONATION_TOKEN 1309 +CONSTANT: ERROR_CANT_DISABLE_MANDATORY 1310 +CONSTANT: ERROR_NO_LOGON_SERVERS 1311 +CONSTANT: ERROR_NO_SUCH_LOGON_SESSION 1312 +CONSTANT: ERROR_NO_SUCH_PRIVILEGE 1313 +CONSTANT: ERROR_PRIVILEGE_NOT_HELD 1314 +CONSTANT: ERROR_INVALID_ACCOUNT_NAME 1315 +CONSTANT: ERROR_USER_EXISTS 1316 +CONSTANT: ERROR_NO_SUCH_USER 1317 +CONSTANT: ERROR_GROUP_EXISTS 1318 +CONSTANT: ERROR_NO_SUCH_GROUP 1319 +CONSTANT: ERROR_MEMBER_IN_GROUP 1320 +CONSTANT: ERROR_MEMBER_NOT_IN_GROUP 1321 +CONSTANT: ERROR_LAST_ADMIN 1322 +CONSTANT: ERROR_WRONG_PASSWORD 1323 +CONSTANT: ERROR_ILL_FORMED_PASSWORD 1324 +CONSTANT: ERROR_PASSWORD_RESTRICTION 1325 +CONSTANT: ERROR_LOGON_FAILURE 1326 +CONSTANT: ERROR_ACCOUNT_RESTRICTION 1327 +CONSTANT: ERROR_INVALID_LOGON_HOURS 1328 +CONSTANT: ERROR_INVALID_WORKSTATION 1329 +CONSTANT: ERROR_PASSWORD_EXPIRED 1330 +CONSTANT: ERROR_ACCOUNT_DISABLED 1331 +CONSTANT: ERROR_NONE_MAPPED 1332 +CONSTANT: ERROR_TOO_MANY_LUIDS_REQUESTED 1333 +CONSTANT: ERROR_LUIDS_EXHAUSTED 1334 +CONSTANT: ERROR_INVALID_SUB_AUTHORITY 1335 +CONSTANT: ERROR_INVALID_ACL 1336 +CONSTANT: ERROR_INVALID_SID 1337 +CONSTANT: ERROR_INVALID_SECURITY_DESCR 1338 +CONSTANT: ERROR_BAD_INHERITANCE_ACL 1340 +CONSTANT: ERROR_SERVER_DISABLED 1341 +CONSTANT: ERROR_SERVER_NOT_DISABLED 1342 +CONSTANT: ERROR_INVALID_ID_AUTHORITY 1343 +CONSTANT: ERROR_ALLOTTED_SPACE_EXCEEDED 1344 +CONSTANT: ERROR_INVALID_GROUP_ATTRIBUTES 1345 +CONSTANT: ERROR_BAD_IMPERSONATION_LEVEL 1346 +CONSTANT: ERROR_CANT_OPEN_ANONYMOUS 1347 +CONSTANT: ERROR_BAD_VALIDATION_CLASS 1348 +CONSTANT: ERROR_BAD_TOKEN_TYPE 1349 +CONSTANT: ERROR_NO_SECURITY_ON_OBJECT 1350 +CONSTANT: ERROR_CANT_ACCESS_DOMAIN_INFO 1351 +CONSTANT: ERROR_INVALID_SERVER_STATE 1352 +CONSTANT: ERROR_INVALID_DOMAIN_STATE 1353 +CONSTANT: ERROR_INVALID_DOMAIN_ROLE 1354 +CONSTANT: ERROR_NO_SUCH_DOMAIN 1355 +CONSTANT: ERROR_DOMAIN_EXISTS 1356 +CONSTANT: ERROR_DOMAIN_LIMIT_EXCEEDED 1357 +CONSTANT: ERROR_INTERNAL_DB_CORRUPTION 1358 +CONSTANT: ERROR_INTERNAL_ERROR 1359 +CONSTANT: ERROR_GENERIC_NOT_MAPPED 1360 +CONSTANT: ERROR_BAD_DESCRIPTOR_FORMAT 1361 +CONSTANT: ERROR_NOT_LOGON_PROCESS 1362 +CONSTANT: ERROR_LOGON_SESSION_EXISTS 1363 +CONSTANT: ERROR_NO_SUCH_PACKAGE 1364 +CONSTANT: ERROR_BAD_LOGON_SESSION_STATE 1365 +CONSTANT: ERROR_LOGON_SESSION_COLLISION 1366 +CONSTANT: ERROR_INVALID_LOGON_TYPE 1367 +CONSTANT: ERROR_CANNOT_IMPERSONATE 1368 +CONSTANT: ERROR_RXACT_INVALID_STATE 1369 +CONSTANT: ERROR_RXACT_COMMIT_FAILURE 1370 +CONSTANT: ERROR_SPECIAL_ACCOUNT 1371 +CONSTANT: ERROR_SPECIAL_GROUP 1372 +CONSTANT: ERROR_SPECIAL_USER 1373 +CONSTANT: ERROR_MEMBERS_PRIMARY_GROUP 1374 +CONSTANT: ERROR_TOKEN_ALREADY_IN_USE 1375 +CONSTANT: ERROR_NO_SUCH_ALIAS 1376 +CONSTANT: ERROR_MEMBER_NOT_IN_ALIAS 1377 +CONSTANT: ERROR_MEMBER_IN_ALIAS 1378 +CONSTANT: ERROR_ALIAS_EXISTS 1379 +CONSTANT: ERROR_LOGON_NOT_GRANTED 1380 +CONSTANT: ERROR_TOO_MANY_SECRETS 1381 +CONSTANT: ERROR_SECRET_TOO_LONG 1382 +CONSTANT: ERROR_INTERNAL_DB_ERROR 1383 +CONSTANT: ERROR_TOO_MANY_CONTEXT_IDS 1384 +CONSTANT: ERROR_LOGON_TYPE_NOT_GRANTED 1385 +CONSTANT: ERROR_NT_CROSS_ENCRYPTION_REQUIRED 1386 +CONSTANT: ERROR_NO_SUCH_MEMBER 1387 +CONSTANT: ERROR_INVALID_MEMBER 1388 +CONSTANT: ERROR_TOO_MANY_SIDS 1389 +CONSTANT: ERROR_LM_CROSS_ENCRYPTION_REQUIRED 1390 +CONSTANT: ERROR_NO_INHERITANCE 1391 +CONSTANT: ERROR_FILE_CORRUPT 1392 +CONSTANT: ERROR_DISK_CORRUPT 1393 +CONSTANT: ERROR_NO_USER_SESSION_KEY 1394 +CONSTANT: ERROR_LICENSE_QUOTA_EXCEEDED 1395 +CONSTANT: ERROR_INVALID_WINDOW_HANDLE 1400 +CONSTANT: ERROR_INVALID_MENU_HANDLE 1401 +CONSTANT: ERROR_INVALID_CURSOR_HANDLE 1402 +CONSTANT: ERROR_INVALID_ACCEL_HANDLE 1403 +CONSTANT: ERROR_INVALID_HOOK_HANDLE 1404 +CONSTANT: ERROR_INVALID_DWP_HANDLE 1405 +CONSTANT: ERROR_TLW_WITH_WSCHILD 1406 +CONSTANT: ERROR_CANNOT_FIND_WND_CLASS 1407 +CONSTANT: ERROR_WINDOW_OF_OTHER_THREAD 1408 +CONSTANT: ERROR_HOTKEY_ALREADY_REGISTERED 1409 +CONSTANT: ERROR_CLASS_ALREADY_EXISTS 1410 +CONSTANT: ERROR_CLASS_DOES_NOT_EXIST 1411 +CONSTANT: ERROR_CLASS_HAS_WINDOWS 1412 +CONSTANT: ERROR_INVALID_INDEX 1413 +CONSTANT: ERROR_INVALID_ICON_HANDLE 1414 +CONSTANT: ERROR_PRIVATE_DIALOG_INDEX 1415 +CONSTANT: ERROR_LISTBOX_ID_NOT_FOUND 1416 +CONSTANT: ERROR_NO_WILDCARD_CHARACTERS 1417 +CONSTANT: ERROR_CLIPBOARD_NOT_OPEN 1418 +CONSTANT: ERROR_HOTKEY_NOT_REGISTERED 1419 +CONSTANT: ERROR_WINDOW_NOT_DIALOG 1420 +CONSTANT: ERROR_CONTROL_ID_NOT_FOUND 1421 +CONSTANT: ERROR_INVALID_COMBOBOX_MESSAGE 1422 +CONSTANT: ERROR_WINDOW_NOT_COMBOBOX 1423 +CONSTANT: ERROR_INVALID_EDIT_HEIGHT 1424 +CONSTANT: ERROR_DC_NOT_FOUND 1425 +CONSTANT: ERROR_INVALID_HOOK_FILTER 1426 +CONSTANT: ERROR_INVALID_FILTER_PROC 1427 +CONSTANT: ERROR_HOOK_NEEDS_HMOD 1428 +CONSTANT: ERROR_GLOBAL_ONLY_HOOK 1429 +CONSTANT: ERROR_JOURNAL_HOOK_SET 1430 +CONSTANT: ERROR_HOOK_NOT_INSTALLED 1431 +CONSTANT: ERROR_INVALID_LB_MESSAGE 1432 +CONSTANT: ERROR_LB_WITHOUT_TABSTOPS 1434 +CONSTANT: ERROR_DESTROY_OBJECT_OF_OTHER_THREAD 1435 +CONSTANT: ERROR_CHILD_WINDOW_MENU 1436 +CONSTANT: ERROR_NO_SYSTEM_MENU 1437 +CONSTANT: ERROR_INVALID_MSGBOX_STYLE 1438 +CONSTANT: ERROR_INVALID_SPI_VALUE 1439 +CONSTANT: ERROR_SCREEN_ALREADY_LOCKED 1440 +CONSTANT: ERROR_HWNDS_HAVE_DIFF_PARENT 1441 +CONSTANT: ERROR_NOT_CHILD_WINDOW 1442 +CONSTANT: ERROR_INVALID_GW_COMMAND 1443 +CONSTANT: ERROR_INVALID_THREAD_ID 1444 +CONSTANT: ERROR_NON_MDICHILD_WINDOW 1445 +CONSTANT: ERROR_POPUP_ALREADY_ACTIVE 1446 +CONSTANT: ERROR_NO_SCROLLBARS 1447 +CONSTANT: ERROR_INVALID_SCROLLBAR_RANGE 1448 +CONSTANT: ERROR_INVALID_SHOWWIN_COMMAND 1449 +CONSTANT: ERROR_NO_SYSTEM_RESOURCES 1450 +CONSTANT: ERROR_NONPAGED_SYSTEM_RESOURCES 1451 +CONSTANT: ERROR_PAGED_SYSTEM_RESOURCES 1452 +CONSTANT: ERROR_WORKING_SET_QUOTA 1453 +CONSTANT: ERROR_PAGEFILE_QUOTA 1454 +CONSTANT: ERROR_COMMITMENT_LIMIT 1455 +CONSTANT: ERROR_MENU_ITEM_NOT_FOUND 1456 +CONSTANT: ERROR_INVALID_KEYBOARD_HANDLE 1457 +CONSTANT: ERROR_HOOK_TYPE_NOT_ALLOWED 1458 +CONSTANT: ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION 1459 +CONSTANT: ERROR_TIMEOUT 1460 +CONSTANT: ERROR_EVENTLOG_FILE_CORRUPT 1500 +CONSTANT: ERROR_EVENTLOG_CANT_START 1501 +CONSTANT: ERROR_LOG_FILE_FULL 1502 +CONSTANT: ERROR_EVENTLOG_FILE_CHANGED 1503 +CONSTANT: RPC_S_INVALID_STRING_BINDING 1700 +CONSTANT: RPC_S_WRONG_KIND_OF_BINDING 1701 +CONSTANT: RPC_S_INVALID_BINDING 1702 +CONSTANT: RPC_S_PROTSEQ_NOT_SUPPORTED 1703 +CONSTANT: RPC_S_INVALID_RPC_PROTSEQ 1704 +CONSTANT: RPC_S_INVALID_STRING_UUID 1705 +CONSTANT: RPC_S_INVALID_ENDPOINT_FORMAT 1706 +CONSTANT: RPC_S_INVALID_NET_ADDR 1707 +CONSTANT: RPC_S_NO_ENDPOINT_FOUND 1708 +CONSTANT: RPC_S_INVALID_TIMEOUT 1709 +CONSTANT: RPC_S_OBJECT_NOT_FOUND 1710 +CONSTANT: RPC_S_ALREADY_REGISTERED 1711 +CONSTANT: RPC_S_TYPE_ALREADY_REGISTERED 1712 +CONSTANT: RPC_S_ALREADY_LISTENING 1713 +CONSTANT: RPC_S_NO_PROTSEQS_REGISTERED 1714 +CONSTANT: RPC_S_NOT_LISTENING 1715 +CONSTANT: RPC_S_UNKNOWN_MGR_TYPE 1716 +CONSTANT: RPC_S_UNKNOWN_IF 1717 +CONSTANT: RPC_S_NO_BINDINGS 1718 +CONSTANT: RPC_S_NO_PROTSEQS 1719 +CONSTANT: RPC_S_CANT_CREATE_ENDPOINT 1720 +CONSTANT: RPC_S_OUT_OF_RESOURCES 1721 +CONSTANT: RPC_S_SERVER_UNAVAILABLE 1722 +CONSTANT: RPC_S_SERVER_TOO_BUSY 1723 +CONSTANT: RPC_S_INVALID_NETWORK_OPTIONS 1724 +CONSTANT: RPC_S_NO_CALL_ACTIVE 1725 +CONSTANT: RPC_S_CALL_FAILED 1726 +CONSTANT: RPC_S_CALL_FAILED_DNE 1727 +CONSTANT: RPC_S_PROTOCOL_ERROR 1728 +CONSTANT: RPC_S_UNSUPPORTED_TRANS_SYN 1730 +CONSTANT: RPC_S_UNSUPPORTED_TYPE 1732 +CONSTANT: RPC_S_INVALID_TAG 1733 +CONSTANT: RPC_S_INVALID_BOUND 1734 +CONSTANT: RPC_S_NO_ENTRY_NAME 1735 +CONSTANT: RPC_S_INVALID_NAME_SYNTAX 1736 +CONSTANT: RPC_S_UNSUPPORTED_NAME_SYNTAX 1737 +CONSTANT: RPC_S_UUID_NO_ADDRESS 1739 +CONSTANT: RPC_S_DUPLICATE_ENDPOINT 1740 +CONSTANT: RPC_S_UNKNOWN_AUTHN_TYPE 1741 +CONSTANT: RPC_S_MAX_CALLS_TOO_SMALL 1742 +CONSTANT: RPC_S_STRING_TOO_LONG 1743 +CONSTANT: RPC_S_PROTSEQ_NOT_FOUND 1744 +CONSTANT: RPC_S_PROCNUM_OUT_OF_RANGE 1745 +CONSTANT: RPC_S_BINDING_HAS_NO_AUTH 1746 +CONSTANT: RPC_S_UNKNOWN_AUTHN_SERVICE 1747 +CONSTANT: RPC_S_UNKNOWN_AUTHN_LEVEL 1748 +CONSTANT: RPC_S_INVALID_AUTH_IDENTITY 1749 +CONSTANT: RPC_S_UNKNOWN_AUTHZ_SERVICE 1750 +CONSTANT: EPT_S_INVALID_ENTRY 1751 +CONSTANT: EPT_S_CANT_PERFORM_OP 1752 +CONSTANT: EPT_S_NOT_REGISTERED 1753 +CONSTANT: RPC_S_NOTHING_TO_EXPORT 1754 +CONSTANT: RPC_S_INCOMPLETE_NAME 1755 +CONSTANT: RPC_S_INVALID_VERS_OPTION 1756 +CONSTANT: RPC_S_NO_MORE_MEMBERS 1757 +CONSTANT: RPC_S_NOT_ALL_OBJS_UNEXPORTED 1758 +CONSTANT: RPC_S_INTERFACE_NOT_FOUND 1759 +CONSTANT: RPC_S_ENTRY_ALREADY_EXISTS 1760 +CONSTANT: RPC_S_ENTRY_NOT_FOUND 1761 +CONSTANT: RPC_S_NAME_SERVICE_UNAVAILABLE 1762 +CONSTANT: RPC_S_INVALID_NAF_ID 1763 +CONSTANT: RPC_S_CANNOT_SUPPORT 1764 +CONSTANT: RPC_S_NO_CONTEXT_AVAILABLE 1765 +CONSTANT: RPC_S_INTERNAL_ERROR 1766 +CONSTANT: RPC_S_ZERO_DIVIDE 1767 +CONSTANT: RPC_S_ADDRESS_ERROR 1768 +CONSTANT: RPC_S_FP_DIV_ZERO 1769 +CONSTANT: RPC_S_FP_UNDERFLOW 1770 +CONSTANT: RPC_S_FP_OVERFLOW 1771 +CONSTANT: RPC_X_NO_MORE_ENTRIES 1772 +CONSTANT: RPC_X_SS_CHAR_TRANS_OPEN_FAIL 1773 +CONSTANT: RPC_X_SS_CHAR_TRANS_SHORT_FILE 1774 +CONSTANT: RPC_X_SS_IN_NULL_CONTEXT 1775 +CONSTANT: RPC_X_SS_CONTEXT_DAMAGED 1777 +CONSTANT: RPC_X_SS_HANDLES_MISMATCH 1778 +CONSTANT: RPC_X_SS_CANNOT_GET_CALL_HANDLE 1779 +CONSTANT: RPC_X_NULL_REF_POINTER 1780 +CONSTANT: RPC_X_ENUM_VALUE_OUT_OF_RANGE 1781 +CONSTANT: RPC_X_BYTE_COUNT_TOO_SMALL 1782 +CONSTANT: RPC_X_BAD_STUB_DATA 1783 +CONSTANT: ERROR_INVALID_USER_BUFFER 1784 +CONSTANT: ERROR_UNRECOGNIZED_MEDIA 1785 +CONSTANT: ERROR_NO_TRUST_LSA_SECRET 1786 +CONSTANT: ERROR_NO_TRUST_SAM_ACCOUNT 1787 +CONSTANT: ERROR_TRUSTED_DOMAIN_FAILURE 1788 +CONSTANT: ERROR_TRUSTED_RELATIONSHIP_FAILURE 1789 +CONSTANT: ERROR_TRUST_FAILURE 1790 +CONSTANT: RPC_S_CALL_IN_PROGRESS 1791 +CONSTANT: ERROR_NETLOGON_NOT_STARTED 1792 +CONSTANT: ERROR_ACCOUNT_EXPIRED 1793 +CONSTANT: ERROR_REDIRECTOR_HAS_OPEN_HANDLES 1794 +CONSTANT: ERROR_PRINTER_DRIVER_ALREADY_INSTALLED 1795 +CONSTANT: ERROR_UNKNOWN_PORT 1796 +CONSTANT: ERROR_UNKNOWN_PRINTER_DRIVER 1797 +CONSTANT: ERROR_UNKNOWN_PRINTPROCESSOR 1798 +CONSTANT: ERROR_INVALID_SEPARATOR_FILE 1799 +CONSTANT: ERROR_INVALID_PRIORITY 1800 +CONSTANT: ERROR_INVALID_PRINTER_NAME 1801 +CONSTANT: ERROR_PRINTER_ALREADY_EXISTS 1802 +CONSTANT: ERROR_INVALID_PRINTER_COMMAND 1803 +CONSTANT: ERROR_INVALID_DATATYPE 1804 +CONSTANT: ERROR_INVALID_ENVIRONMENT 1805 +CONSTANT: RPC_S_NO_MORE_BINDINGS 1806 +CONSTANT: ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT 1807 +CONSTANT: ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT 1808 +CONSTANT: ERROR_NOLOGON_SERVER_TRUST_ACCOUNT 1809 +CONSTANT: ERROR_DOMAIN_TRUST_INCONSISTENT 1810 +CONSTANT: ERROR_SERVER_HAS_OPEN_HANDLES 1811 +CONSTANT: ERROR_RESOURCE_DATA_NOT_FOUND 1812 +CONSTANT: ERROR_RESOURCE_TYPE_NOT_FOUND 1813 +CONSTANT: ERROR_RESOURCE_NAME_NOT_FOUND 1814 +CONSTANT: ERROR_RESOURCE_LANG_NOT_FOUND 1815 +CONSTANT: ERROR_NOT_ENOUGH_QUOTA 1816 +CONSTANT: RPC_S_NO_INTERFACES 1817 +CONSTANT: RPC_S_CALL_CANCELLED 1818 +CONSTANT: RPC_S_BINDING_INCOMPLETE 1819 +CONSTANT: RPC_S_COMM_FAILURE 1820 +CONSTANT: RPC_S_UNSUPPORTED_AUTHN_LEVEL 1821 +CONSTANT: RPC_S_NO_PRINC_NAME 1822 +CONSTANT: RPC_S_NOT_RPC_ERROR 1823 +CONSTANT: RPC_S_UUID_LOCAL_ONLY 1824 +CONSTANT: RPC_S_SEC_PKG_ERROR 1825 +CONSTANT: RPC_S_NOT_CANCELLED 1826 +CONSTANT: RPC_X_INVALID_ES_ACTION 1827 +CONSTANT: RPC_X_WRONG_ES_VERSION 1828 +CONSTANT: RPC_X_WRONG_STUB_VERSION 1829 +CONSTANT: RPC_X_INVALID_PIPE_OBJECT 1830 +CONSTANT: RPC_X_INVALID_PIPE_OPERATION 1831 +CONSTANT: RPC_X_WRONG_PIPE_VERSION 1832 +CONSTANT: RPC_S_GROUP_MEMBER_NOT_FOUND 1898 +CONSTANT: EPT_S_CANT_CREATE 1899 +CONSTANT: RPC_S_INVALID_OBJECT 1900 +CONSTANT: ERROR_INVALID_TIME 1901 +CONSTANT: ERROR_INVALID_FORM_NAME 1902 +CONSTANT: ERROR_INVALID_FORM_SIZE 1903 +CONSTANT: ERROR_ALREADY_WAITING 1904 +CONSTANT: ERROR_PRINTER_DELETED 1905 +CONSTANT: ERROR_INVALID_PRINTER_STATE 1906 +CONSTANT: ERROR_PASSWORD_MUST_CHANGE 1907 +CONSTANT: ERROR_DOMAIN_CONTROLLER_NOT_FOUND 1908 +CONSTANT: ERROR_ACCOUNT_LOCKED_OUT 1909 +CONSTANT: OR_INVALID_OXID 1910 +CONSTANT: OR_INVALID_OID 1911 +CONSTANT: OR_INVALID_SET 1912 +CONSTANT: RPC_S_SEND_INCOMPLETE 1913 +CONSTANT: ERROR_INVALID_PIXEL_FORMAT 2000 +CONSTANT: ERROR_BAD_DRIVER 2001 +CONSTANT: ERROR_INVALID_WINDOW_STYLE 2002 +CONSTANT: ERROR_METAFILE_NOT_SUPPORTED 2003 +CONSTANT: ERROR_TRANSFORM_NOT_SUPPORTED 2004 +CONSTANT: ERROR_CLIPPING_NOT_SUPPORTED 2005 +CONSTANT: ERROR_BAD_USERNAME 2202 +CONSTANT: ERROR_NOT_CONNECTED 2250 +CONSTANT: ERROR_OPEN_FILES 2401 +CONSTANT: ERROR_ACTIVE_CONNECTIONS 2402 +CONSTANT: ERROR_DEVICE_IN_USE 2404 +CONSTANT: ERROR_UNKNOWN_PRINT_MONITOR 3000 +CONSTANT: ERROR_PRINTER_DRIVER_IN_USE 3001 +CONSTANT: ERROR_SPOOL_FILE_NOT_FOUND 3002 +CONSTANT: ERROR_SPL_NO_STARTDOC 3003 +CONSTANT: ERROR_SPL_NO_ADDJOB 3004 +CONSTANT: ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED 3005 +CONSTANT: ERROR_PRINT_MONITOR_ALREADY_INSTALLED 3006 +CONSTANT: ERROR_INVALID_PRINT_MONITOR 3007 +CONSTANT: ERROR_PRINT_MONITOR_IN_USE 3008 +CONSTANT: ERROR_PRINTER_HAS_JOBS_QUEUED 3009 +CONSTANT: ERROR_SUCCESS_REBOOT_REQUIRED 3010 +CONSTANT: ERROR_SUCCESS_RESTART_REQUIRED 3011 +CONSTANT: ERROR_WINS_INTERNAL 4000 +CONSTANT: ERROR_CAN_NOT_DEL_LOCAL_WINS 4001 +CONSTANT: ERROR_STATIC_INIT 4002 +CONSTANT: ERROR_INC_BACKUP 4003 +CONSTANT: ERROR_FULL_BACKUP 4004 +CONSTANT: ERROR_REC_NON_EXISTENT 4005 +CONSTANT: ERROR_RPL_NOT_ALLOWED 4006 +CONSTANT: ERROR_NO_BROWSER_SERVERS_FOUND 6118 + +CONSTANT: SUBLANG_NEUTRAL 0 +CONSTANT: LANG_NEUTRAL 0 +CONSTANT: SUBLANG_DEFAULT 1 + +CONSTANT: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 +CONSTANT: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 +CONSTANT: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 +CONSTANT: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 +CONSTANT: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 +CONSTANT: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 +CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF + +: make-lang-id ( lang1 lang2 -- n ) + 10 shift bitor ; inline + +ERROR: error-message-failed id ; +:: n>win32-error-string ( id -- string ) + { + FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_ARGUMENT_ARRAY + } flags + f + id + LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id + 32768 [ "TCHAR" ] keep + f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip + utf16n alien>string [ blank? ] trim ; + +: win32-error-string ( -- str ) + GetLastError n>win32-error-string ; + +: (win32-error) ( n -- ) + dup zero? [ + drop + ] [ + win32-error-string throw + ] if ; + +: win32-error ( -- ) + GetLastError (win32-error) ; + +: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ; +: win32-error>0 ( n -- ) 0 > [ win32-error ] when ; +: win32-error<0 ( n -- ) 0 < [ win32-error ] when ; +: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; + +: invalid-handle? ( handle -- ) + INVALID_HANDLE_VALUE = [ + win32-error-string throw + ] when ; + +CONSTANT: expected-io-errors + { + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } + +: expected-io-error? ( error-code -- ? ) + expected-io-errors member? ; + +: expected-io-error ( error-code -- ) + dup expected-io-error? [ + drop + ] [ + win32-error-string throw + ] if ; + +: io-error ( return-value -- ) + { 0 f } member? [ GetLastError expected-io-error ] when ; diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index a034856b34..1753ff1ce1 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -1,5 +1,5 @@ USING: assocs memoize locals kernel accessors init fonts math -combinators windows windows.types windows.gdi32 ; +combinators windows.errors windows.types windows.gdi32 ; IN: windows.fonts : windows-font-name ( string -- string' ) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 1a513df186..e654b68bdc 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1110,7 +1110,19 @@ FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ; ! FUNCTION: FoldStringA ! FUNCTION: FoldStringW ! FUNCTION: FormatMessageA -! FUNCTION: FormatMessageW +FUNCTION: DWORD FormatMessageW ( + DWORD dwFlags, + LPCVOID lpSource, + DWORD dwMessageId, + DWORD dwLanguageId, + LPTSTR lpBuffer, + DWORD nSize, + void* Arguments + ) ; + +ALIAS: FormatMessage FormatMessageW + + FUNCTION: BOOL FreeConsole ( ) ; ! FUNCTION: FreeEnvironmentStringsA FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index e69a9213b0..864700cb0f 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,6 +1,6 @@ USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows windows.types debugger io accessors -math.order namespaces make math.parser windows.kernel32 +kernel sequences windows.errors windows.types debugger io +accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 @@ -120,7 +120,7 @@ TUPLE: ole32-error error-code ; C: ole32-error M: ole32-error error. - "COM method failed: " print error-code>> (win32-error-string) print ; + "COM method failed: " print error-code>> n>win32-error-string print ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 7802ceb297..016f5ab149 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax combinators io.encodings.utf16n io.files io.pathnames kernel -windows windows.com windows.com.syntax windows.user32 -windows.ole32 ; +windows.errors windows.com windows.com.syntax windows.user32 +windows.ole32 windows ; IN: windows.shell32 CONSTANT: CSIDL_DESKTOP HEX: 00 diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index e63834d369..71726a554a 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar math.bitwise ; +USING: alien alien.c-types kernel math windows.errors +windows.kernel32 namespaces calendar math.bitwise ; IN: windows.time : >64bit ( lo hi -- n ) - 32 shift bitor ; + 32 shift bitor ; inline : windows-1601 ( -- timestamp ) 1601 1 1 0 0 0 instant ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 20bae06f30..062196c3f8 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -100,7 +100,7 @@ TYPEDEF: HANDLE HGDIOBJ TYPEDEF: HANDLE HGLOBAL TYPEDEF: HANDLE HHOOK TYPEDEF: HANDLE HINSTANCE -TYPEDEF: HANDLE HKEY +TYPEDEF: DWORD HKEY TYPEDEF: HANDLE HKL TYPEDEF: HANDLE HLOCAL TYPEDEF: HANDLE HMENU diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index fb0c134b9a..feb0bef7a8 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string io.encodings.utf16n accessors arrays combinators destructors -cache namespaces init fonts alien.c-types windows windows.usp10 +cache namespaces init fonts alien.c-types windows.usp10 windows.offscreen windows.gdi32 windows.ole32 windows.types -windows.fonts opengl.textures locals ; +windows.fonts opengl.textures locals windows.errors ; IN: windows.uniscribe TUPLE: script-string font string metrics ssa size image disposed ; diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor index 902b1bec8d..92ba8b638a 100755 --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -1,61 +1,5 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax alien.c-types alien.strings arrays -combinators kernel math namespaces parser sequences -windows.errors windows.types windows.kernel32 words -io.encodings.utf16n ; IN: windows -: lo-word ( wparam -- lo ) *short ; inline -: hi-word ( wparam -- hi ) -16 shift lo-word ; inline CONSTANT: MAX_UNICODE_PATH 32768 - -! You must LocalFree the return value! -FUNCTION: void* error_message ( DWORD id ) ; - -: (win32-error-string) ( n -- string ) - error_message - dup utf16n alien>string - swap LocalFree drop ; - -: win32-error-string ( -- str ) - GetLastError (win32-error-string) ; - -: (win32-error) ( n -- ) - dup zero? [ - drop - ] [ - win32-error-string throw - ] if ; - -: win32-error ( -- ) - GetLastError (win32-error) ; - -: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ; -: win32-error>0 ( n -- ) 0 > [ win32-error ] when ; -: win32-error<0 ( n -- ) 0 < [ win32-error ] when ; -: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; - -: invalid-handle? ( handle -- ) - INVALID_HANDLE_VALUE = [ - win32-error-string throw - ] when ; - -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable - -: expected-io-error? ( error-code -- ? ) - expected-io-errors member? ; - -: expected-io-error ( error-code -- ) - dup expected-io-error? [ - drop - ] [ - (win32-error-string) throw - ] if ; - -: io-error ( return-value -- ) - { 0 f } member? [ GetLastError expected-io-error ] when ; diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 06df74cd4c..f0d32588f5 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel math sequences windows.types windows.kernel32 -windows.errors windows math.bitwise io.encodings.utf16n ; +windows.errors math.bitwise io.encodings.utf16n ; IN: windows.winsock USE: libc @@ -403,7 +403,7 @@ CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 : (winsock-error-string) ( n -- str ) ! #! WSAStartup returns the error code 'n' directly dup winsock-expected-error? - [ drop f ] [ error_message utf16n alien>string ] if ; + [ drop f ] [ n>win32-error-string ] if ; : winsock-error-string ( -- string/f ) WSAGetLastError (winsock-error-string) ; From 65d76e6509af3399ae0ea8bb8c4446ea485855f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 10:25:59 -0500 Subject: [PATCH 68/83] finish fixing the using list for windows.errors, more ffi bindings --- .../windows/nt/privileges/privileges.factor | 2 +- basis/io/mmap/windows/windows.factor | 6 +-- basis/windows/advapi32/advapi32.factor | 41 ++++++++++++++++++- extra/game-input/dinput/dinput.factor | 8 ++-- extra/system-info/windows/nt/nt.factor | 4 +- extra/system-info/windows/windows.factor | 2 +- 6 files changed, 50 insertions(+), 13 deletions(-) diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 64218f75b0..33577a9394 100755 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.ports io.backend.windows io.files.windows kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors -io.backend.windows.privileges ; +io.backend.windows.privileges windows.errors ; IN: io.backend.windows.nt.privileges TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index ebd8109d14..8fdc7fefd9 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.backend.windows io.files.windows io.backend.windows.privileges kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system -accessors locals ; +accessors locals windows.errors ; IN: io.mmap.windows : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) @@ -12,8 +12,8 @@ IN: io.mmap.windows MapViewOfFile [ win32-error=0/f ] keep ; :: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) - [let | lo [ length HEX: ffffffff bitand ] - hi [ length -32 shift HEX: ffffffff bitand ] | + [let | lo [ length 32 bits ] + hi [ length -32 shift 32 bits ] | { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ path access-mode create-mode 0 open-file |dispose dup handle>> f protect hi lo f create-file-mapping |dispose diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index f715af378b..fd037cb2a0 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -894,15 +894,52 @@ FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LP ! : RegCreateKeyW ! : RegDeleteKeyA ; ! : RegDeleteKeyW ; + +FUNCTION: LONG RegDeleteKeyExW ( + HKEY hKey, + LPCTSTR lpSubKey, + DWORD Reserved, + LPTSTR lpClass, + DWORD dwOptions, + REGSAM samDesired, + LPSECURITY_ATTRIBUTES lpSecurityAttributes, + PHKEY phkResult, + LPDWORD lpdwDisposition + ) ; + +ALIAS: RegDeleteKeyEx RegDeleteKeyExW + ! : RegDeleteValueA ; ! : RegDeleteValueW ; ! : RegDisablePredefinedCache ; ! : RegEnumKeyA ; ! : RegEnumKeyExA ; -! : RegEnumKeyExW ; +FUNCTION: LONG RegEnumKeyExW ( + HKEY hKey, + DWORD dwIndex, + LPTSTR lpName, + LPDWORD lpcName, + LPDWORD lpReserved, + LPTSTR lpClass, + LPDWORD lpcClass, + PFILETIME lpftLastWriteTime + ) ; ! : RegEnumKeyW ; ! : RegEnumValueA ; -! : RegEnumValueW ; + +FUNCTION: LONG RegEnumValueW ( + HKEY hKey, + DWORD dwIndex, + LPTSTR lpValueName, + LPDWORD lpcchValueName, + LPDWORD lpReserved, + LPDWORD lpType, + LPBYTE lpData, + LPDWORD lpcbData + ) ; + +ALIAS: RegEnumValue RegEnumValueW + ! : RegFlushKey ; ! : RegGetKeySecurity ; ! : RegLoadKeyA ; diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor index a2beaf6d9b..ce87c12237 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/extra/game-input/dinput/dinput.factor @@ -2,10 +2,10 @@ USING: windows.dinput windows.dinput.constants parser alien.c-types windows.ole32 namespaces assocs kernel arrays vectors windows.kernel32 windows.com windows.dinput shuffle windows.user32 windows.messages sequences combinators locals -math.rectangles accessors math windows alien -alien.strings io.encodings.utf16 io.encodings.utf16n -continuations byte-arrays game-input.dinput.keys-array -game-input ui.backend.windows ; +math.rectangles accessors math alien alien.strings +io.encodings.utf16 io.encodings.utf16n continuations +byte-arrays game-input.dinput.keys-array game-input +ui.backend.windows windows.errors ; IN: game-input.dinput SINGLETON: dinput-game-input-backend diff --git a/extra/system-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor index 7f71e08e83..5be2dc89e2 100755 --- a/extra/system-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings kernel libc math namespaces system-info.backend system-info.windows windows windows.advapi32 -windows.kernel32 system byte-arrays ; +windows.kernel32 system byte-arrays windows.errors ; IN: system-info.windows.nt M: winnt cpus ( -- n ) @@ -41,6 +41,6 @@ M: winnt available-virtual-mem ( -- n ) GetComputerName win32-error=0/f alien>native-string ; : username ( -- string ) - UNLEN 1+ + UNLEN 1 + [ dup ] keep GetUserName win32-error=0/f alien>native-string ; diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor index 66abb59ee9..4d23430131 100755 --- a/extra/system-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader system-info.backend -system alien.strings ; +system alien.strings windows.errors ; IN: system-info.windows : system-info ( -- SYSTEM_INFO ) From 64ac2bae6d309ab15225178b65f394621aed99b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 10:27:18 -0500 Subject: [PATCH 69/83] make tools.scaffold.windows unportable --- basis/tools/scaffold/windows/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/tools/scaffold/windows/tags.txt diff --git a/basis/tools/scaffold/windows/tags.txt b/basis/tools/scaffold/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/scaffold/windows/tags.txt @@ -0,0 +1 @@ +unportable From 31ce2252e775535a2520c1cc1ab3e43fe8db606e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 13:11:51 -0500 Subject: [PATCH 70/83] fix win32 error handling --- basis/io/backend/windows/nt/nt.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 46f8be22f0..bb5c115549 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- ) GetLastError { { [ dup expected-io-error? ] [ drop f ] } { [ dup eof? ] [ drop t ] } - [ win32-error-string throw ] + [ n>win32-error-string throw ] } cond ] [ f ] if ; From 6ec73b2a2a8cff35a1c6f705efab29a01b9ae3e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 13:47:49 -0500 Subject: [PATCH 71/83] fix bootstrap on windows. here's an opportunity to use literals. --- basis/io/backend/windows/nt/nt.factor | 2 +- basis/windows/errors/errors.factor | 15 +++++++-------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index bb5c115549..4dfe02d651 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- ) { [ dup integer? ] [ ] } { [ dup array? ] [ first dup eof? - [ drop 0 ] [ win32-error-string throw ] if + [ drop 0 ] [ n>win32-error-string throw ] if ] } } cond ] with-timeout ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 34fd019889..e08704d469 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,6 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories -io.encodings.string io.encodings.utf16n alien.strings ; +io.encodings.string io.encodings.utf16n alien.strings +arrays ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -731,13 +732,11 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -CONSTANT: expected-io-errors - { - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT - } +: expected-io-errors ( -- seq ) + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT 4array ; foldable : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; From 4a5009048f55f6df2dae731d12de1643f09a809d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 15:22:32 -0500 Subject: [PATCH 72/83] support fullscreen mode in windows ui --- basis/ui/backend/windows/windows.factor | 48 ++++++++++++++++++++++++ basis/windows/user32/user32.factor | 49 +++++++++++++++++++++++-- 2 files changed, 93 insertions(+), 4 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 42b80af8a9..76c0dc4e01 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -555,6 +555,54 @@ M: windows-ui-backend (with-ui) M: windows-ui-backend beep ( -- ) 0 MessageBeep drop ; +: fullscreen-RECT ( hwnd -- RECT ) + MONITOR_DEFAULTTONEAREST MonitorFromWindow + "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize + [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; + +: hwnd>RECT ( hwnd -- RECT ) + "RECT" [ GetWindowRect win32-error=0/f ] keep ; + +: fullscreen-flags ( -- n ) + { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline + +: enter-fullscreen ( world -- ) + handle>> hWnd>> + { + [ + GWL_STYLE GetWindowLong + fullscreen-flags unmask + ] + [ GWL_STYLE rot SetWindowLong win32-error=0/f ] + [ + HWND_TOP + over hwnd>RECT get-RECT-dimensions + SWP_FRAMECHANGED + SetWindowPos win32-error=0/f + ] + [ SW_MAXIMIZE ShowWindow win32-error=0/f ] + } cleave ; + +: exit-fullscreen ( world -- ) + handle>> hWnd>> + { + [ + GWL_STYLE GetWindowLong + fullscreen-flags bitor + ] + [ GWL_STYLE rot SetWindowLong win32-error=0/f ] + [ + f + over hwnd>RECT get-RECT-dimensions + { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags + SetWindowPos win32-error=0/f + ] + [ SW_RESTORE ShowWindow win32-error=0/f ] + } cleave ; + +M: windows-ui-backend set-fullscreen* ( ? world -- ) + swap [ enter-fullscreen ] [ exit-fullscreen ] if ; + windows-ui-backend ui-backend set-global [ "ui.tools" ] main-vocab-hook set-global diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index f3bc1becb2..1e694bcbe4 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -542,12 +542,46 @@ C-STRUCT: DEV_BROADCAST_HDR { "DWORD" "dbch_size" } { "DWORD" "dbch_devicetype" } { "DWORD" "dbch_reserved" } ; + C-STRUCT: DEV_BROADCAST_DEVICEW { "DWORD" "dbcc_size" } { "DWORD" "dbcc_devicetype" } { "DWORD" "dbcc_reserved" } { "GUID" "dbcc_classguid" } - { "WCHAR[1]" "dbcc_name" } ; + { { "WCHAR" 1 } "dbcc_name" } ; + +CONSTANT: CCHDEVICENAME 32 + +C-STRUCT: MONITORINFOEX + { "DWORD" "cbSize" } + { "RECT" "rcMonitor" } + { "RECT" "rcWork" } + { "DWORD" "dwFlags" } + { { "TCHAR" CCHDEVICENAME } "szDevice" } ; + +TYPEDEF: MONITORINFOEX* LPMONITORINFOEX +TYPEDEF: MONITORINFOEX* LPMONITORINFO + +CONSTANT: MONITOR_DEFAULTTONULL 0 +CONSTANT: MONITOR_DEFAULTTOPRIMARY 1 +CONSTANT: MONITOR_DEFAULTTONEAREST 2 +CONSTANT: MONITORINFOF_PRIMARY 1 +CONSTANT: SWP_NOSIZE 1 +CONSTANT: SWP_NOMOVE 2 +CONSTANT: SWP_NOZORDER 4 +CONSTANT: SWP_NOREDRAW 8 +CONSTANT: SWP_NOACTIVATE 16 +CONSTANT: SWP_FRAMECHANGED 32 +CONSTANT: SWP_SHOWWINDOW 64 +CONSTANT: SWP_HIDEWINDOW 128 +CONSTANT: SWP_NOCOPYBITS 256 +CONSTANT: SWP_NOOWNERZORDER 512 +CONSTANT: SWP_NOSENDCHANGING 1024 +CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED +CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER +CONSTANT: SWP_DEFERERASE 8192 +CONSTANT: SWP_ASYNCWINDOWPOS 16384 + LIBRARY: user32 @@ -910,7 +944,10 @@ ALIAS: GetMessage GetMessageW ! FUNCTION: GetMessagePos ! FUNCTION: GetMessageTime ! FUNCTION: GetMonitorInfoA -! FUNCTION: GetMonitorInfoW + +FUNCTION: BOOL GetMonitorInfoW ( HMONITOR hMonitor, LPMONITORINFO lpmi ) ; +ALIAS: GetMonitorInfo GetMonitorInfoW + ! FUNCTION: GetMouseMovePointsEx ! FUNCTION: GetNextDlgGroupItem ! FUNCTION: GetNextDlgTabItem @@ -961,6 +998,8 @@ FUNCTION: HWND GetWindow ( HWND hWnd, UINT uCmd ) ; ! FUNCTION: GetWindowInfo ! FUNCTION: GetWindowLongA ! FUNCTION: GetWindowLongW +FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ; +ALIAS: GetWindowLong GetWindowLongW ! FUNCTION: GetWindowModuleFileName ! FUNCTION: GetWindowModuleFileNameA ! FUNCTION: GetWindowModuleFileNameW @@ -1127,7 +1166,7 @@ ALIAS: MessageBoxEx MessageBoxExW ! FUNCTION: ModifyMenuW ! FUNCTION: MonitorFromPoint ! FUNCTION: MonitorFromRect -! FUNCTION: MonitorFromWindow +FUNCTION: HMONITOR MonitorFromWindow ( HWND hWnd, DWORD dwFlags ) ; ! FUNCTION: mouse_event @@ -1303,12 +1342,14 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; ! FUNCTION: SetWindowContextHelpId ! FUNCTION: SetWindowLongA ! FUNCTION: SetWindowLongW +FUNCTION: LONG_PTR SetWindowLongW ( HANDLE hWnd, int index, LONG_PTR dwNewLong ) ; +ALIAS: SetWindowLong SetWindowLongW ! FUNCTION: SetWindowPlacement FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ; : HWND_BOTTOM ( -- alien ) 1 ; : HWND_NOTOPMOST ( -- alien ) -2 ; -: HWND_TOP ( -- alien ) 0 ; +CONSTANT: HWND_TOP f : HWND_TOPMOST ( -- alien ) -1 ; ! FUNCTION: SetWindowRgn From 48dbd4022cfedd4a2cb77c55102efdfb052bbe93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 17:13:52 -0500 Subject: [PATCH 73/83] Remove obsolete benchmark --- extra/benchmark/typecheck3/typecheck3.factor | 2 +- extra/benchmark/typecheck4/authors.txt | 1 - extra/benchmark/typecheck4/typecheck4.factor | 12 ------------ 3 files changed, 1 insertion(+), 14 deletions(-) delete mode 100755 extra/benchmark/typecheck4/authors.txt delete mode 100644 extra/benchmark/typecheck4/typecheck4.factor diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index c4887c03c4..fccd80a607 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/extra/benchmark/typecheck3/typecheck3.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck3 TUPLE: hello n ; -: hello-n* ( obj -- val ) dup tag 2 eq? [ 2 slot ] [ 3 throw ] if ; +: hello-n* ( obj -- val ) 2 slot ; : foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; diff --git a/extra/benchmark/typecheck4/authors.txt b/extra/benchmark/typecheck4/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/benchmark/typecheck4/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor deleted file mode 100644 index c881864304..0000000000 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: math kernel kernel.private slots.private ; -IN: benchmark.typecheck4 - -TUPLE: hello n ; - -: hello-n* ( obj -- val ) 2 slot ; - -: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; - -: typecheck-main ( -- ) 0 hello boa foo 2drop ; - -MAIN: typecheck-main From f9ec0a07c5cbae0947033774b6e2cc626dbf3155 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 18:00:49 -0500 Subject: [PATCH 74/83] Fix PICs for x86-64 --- basis/bootstrap/image/image.factor | 2 +- basis/cpu/x86/bootstrap.factor | 1 + vm/cpu-x86.64.S | 2 +- vm/cpu-x86.h | 4 ++-- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index dde945e9af..fe1677a7a0 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -98,7 +98,7 @@ SYMBOL: jit-define-rt SYMBOL: jit-define-offset : compute-offset ( -- offset ) - building get length jit-define-rc get rc-absolute-cell = cell 4 ? - ; + building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; : jit-rel ( rc rt -- ) jit-define-rt set diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fe5b85057d..337c3ae575 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -241,6 +241,7 @@ big-endian off temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! key = class temp2 temp1 MOV + bootstrap-cell 8 = [ temp2 1 SHL ] when ! key &= cache.length - 1 temp2 mega-cache-size get 1- bootstrap-cell * AND ! cache += array-start-offset diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 26cb753d59..a110bf1d51 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -78,6 +78,6 @@ DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): sub $STACK_PADDING,%rsp call MANGLE(inline_cache_miss) add $STACK_PADDING,%rsp - jmp *WORD_XT_OFFSET(%rax) + jmp *%rax #include "cpu-x86.S" diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index ab09893707..0888ec57fd 100755 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -25,11 +25,11 @@ INLINE void check_call_site(CELL return_address) INLINE CELL get_call_target(CELL return_address) { check_call_site(return_address); - return *(F_FIXNUM *)(return_address - 4) + return_address; + return *(int *)(return_address - 4) + return_address; } INLINE void set_call_target(CELL return_address, CELL target) { check_call_site(return_address); - *(F_FIXNUM *)(return_address - 4) = (target - return_address); + *(int *)(return_address - 4) = (target - return_address); } From bb84d493fa1fd26d68fcb8df0867925d36beb9a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 18:35:34 -0500 Subject: [PATCH 75/83] make windows.fonts unportable --- basis/windows/fonts/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/windows/fonts/tags.txt diff --git a/basis/windows/fonts/tags.txt b/basis/windows/fonts/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/fonts/tags.txt @@ -0,0 +1 @@ +unportable From d72bf515f8cae50e5b521d6d3a1393e1431d34c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 19:06:54 -0500 Subject: [PATCH 76/83] tools.walker: fix tests --- basis/tools/walker/walker-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index c8ab2512f6..6f87792faa 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -1,7 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug -generic.standard sequences.private kernel.private +generic.single sequences.private kernel.private tools.continuations accessors words ; IN: tools.walker.tests From 7be231f6f8d3550e3dd8573c6110347c1414ae2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 19:07:13 -0500 Subject: [PATCH 77/83] Clean up code duplication in quotations.c --- vm/jit.c | 34 ++++++ vm/jit.h | 25 +++++ vm/quotations.c | 271 +++++++++++++++++------------------------------- vm/quotations.h | 2 +- 4 files changed, 153 insertions(+), 179 deletions(-) diff --git a/vm/jit.c b/vm/jit.c index 8145d18b36..8d7dcd657a 100644 --- a/vm/jit.c +++ b/vm/jit.c @@ -23,6 +23,18 @@ void jit_init(F_JIT *jit, CELL jit_type, CELL owner) if(stack_traces_p()) growable_array_add(&jit->literals,jit->owner); + + jit->computing_offset_p = false; +} + +/* Facility to convert compiled code offsets to quotation offsets. +Call jit_compute_offset() with the compiled code offset, then emit +code, and at the end jit->position is the quotation position. */ +void jit_compute_position(F_JIT *jit, CELL offset) +{ + jit->computing_offset_p = true; + jit->position = 0; + jit->offset = offset; } /* Allocates memory */ @@ -75,11 +87,33 @@ static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p) void jit_emit(F_JIT *jit, CELL template) { REGISTER_ROOT(template); + bool rel_p; F_REL rel = rel_to_emit(jit,template,&rel_p); if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); + F_BYTE_ARRAY *code = code_to_emit(template); + + if(jit->computing_offset_p) + { + CELL size = array_capacity(code); + + if(jit->offset == 0) + { + jit->position--; + jit->computing_offset_p = false; + } + else if(jit->offset < size) + { + jit->position++; + jit->computing_offset_p = false; + } + else + jit->offset -= size; + } + growable_byte_array_append(&jit->code,code + 1,array_capacity(code)); + UNREGISTER_ROOT(template); } diff --git a/vm/jit.h b/vm/jit.h index 2085c8c8bd..4ea72ee9a4 100644 --- a/vm/jit.h +++ b/vm/jit.h @@ -4,10 +4,17 @@ typedef struct { F_GROWABLE_BYTE_ARRAY code; F_GROWABLE_BYTE_ARRAY relocation; F_GROWABLE_ARRAY literals; + bool computing_offset_p; + F_FIXNUM position; + CELL offset; } F_JIT; void jit_init(F_JIT *jit, CELL jit_type, CELL owner); + +void jit_compute_position(F_JIT *jit, CELL offset); + F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); + void jit_dispose(F_JIT *jit); INLINE F_BYTE_ARRAY *code_to_emit(CELL template) @@ -60,3 +67,21 @@ INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word) jit_emit(jit,word->subprimitive); } + +INLINE F_FIXNUM jit_get_position(F_JIT *jit) +{ + if(jit->computing_offset_p) + { + /* If this is still on, jit_emit() didn't clear it, + so the offset was out of bounds */ + return -1; + } + else + return jit->position; +} + +INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position) +{ + if(jit->computing_offset_p) + jit->position = position; +} diff --git a/vm/quotations.c b/vm/quotations.c index d358a2c571..909bba501e 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -22,8 +22,7 @@ special words which are open-coded, see below), then no prolog/epilog is generated. 3) When in tail position and immediately preceded by literal arguments, the -'if' and 'dispatch' conditionals are generated inline, instead of as a call to -the 'if' word. +'if' is generated inline, instead of as a call to the 'if' word. 4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are open-coded as retain stack manipulation surrounding a subroutine call. @@ -124,39 +123,22 @@ static bool jit_stack_frame_p(F_ARRAY *array) return false; } -void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) -{ - if(code->block.type != QUOTATION_TYPE) - critical_error("Bad param to set_quot_xt",(CELL)code); - - quot->code = code; - quot->xt = (XT)(code + 1); - quot->compiledp = T; -} - -#define EMIT_TAIL_CALL { \ - if(stack_frame) jit_emit(&jit,userenv[JIT_EPILOG]); \ +#define TAIL_CALL { \ + if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \ tail_call = true; \ } -/* Might GC */ -void jit_compile(CELL quot, bool relocate) +/* Allocates memory */ +static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate) { - if(untag_quotation(quot)->compiledp != F) - return; - - CELL array = untag_quotation(quot)->array; - - REGISTER_ROOT(quot); REGISTER_ROOT(array); - F_JIT jit; - jit_init(&jit,QUOTATION_TYPE,quot); - bool stack_frame = jit_stack_frame_p(untag_object(array)); + jit_set_position(jit,0); + if(stack_frame) - jit_emit(&jit,userenv[JIT_PROLOG]); + jit_emit(jit,userenv[JIT_PROLOG]); CELL i; CELL length = array_capacity(untag_object(array)); @@ -164,6 +146,8 @@ void jit_compile(CELL quot, bool relocate) for(i = 0; i < length; i++) { + jit_set_position(jit,i); + CELL obj = array_nth(untag_object(array),i); REGISTER_ROOT(obj); @@ -177,39 +161,39 @@ void jit_compile(CELL quot, bool relocate) /* Intrinsics */ if(word->subprimitive != F) - jit_emit_subprimitive(&jit,word); + jit_emit_subprimitive(jit,word); /* The (execute) primitive is special-cased */ else if(obj == userenv[JIT_EXECUTE_WORD]) { if(i == length - 1) { - EMIT_TAIL_CALL; - jit_emit(&jit,userenv[JIT_EXECUTE_JUMP]); + TAIL_CALL; + jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); } else - jit_emit(&jit,userenv[JIT_EXECUTE_CALL]); + jit_emit(jit,userenv[JIT_EXECUTE_CALL]); } /* Everything else */ else { if(i == length - 1) { - EMIT_TAIL_CALL; - jit_word_jump(&jit,obj); + TAIL_CALL; + jit_word_jump(jit,obj); } else - jit_word_call(&jit,obj); + jit_word_call(jit,obj); } break; case WRAPPER_TYPE: wrapper = untag_object(obj); - jit_push(&jit,wrapper->object); + jit_push(jit,wrapper->object); break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - jit_emit(&jit,userenv[JIT_SAVE_STACK]); - jit_emit_with(&jit,userenv[JIT_PRIMITIVE],obj); + jit_emit(jit,userenv[JIT_SAVE_STACK]); + jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj); i++; @@ -217,58 +201,72 @@ void jit_compile(CELL quot, bool relocate) break; } case QUOTATION_TYPE: + /* if preceeded by two literal quotations (this is why if and ? are + mutually recursive in the library, but both still work) */ if(jit_fast_if_p(untag_object(array),i)) { - EMIT_TAIL_CALL; + TAIL_CALL; - jit_compile(array_nth(untag_object(array),i),relocate); - jit_compile(array_nth(untag_object(array),i + 1),relocate); + if(compiling) + { + jit_compile(array_nth(untag_object(array),i),relocate); + jit_compile(array_nth(untag_object(array),i + 1),relocate); + } - jit_emit_with(&jit,userenv[JIT_IF_1],array_nth(untag_object(array),i)); - jit_emit_with(&jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1)); + jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_object(array),i)); + jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1)); i += 2; break; } + /* dip */ else if(jit_fast_dip_p(untag_object(array),i)) { - jit_compile(obj,relocate); - jit_emit_with(&jit,userenv[JIT_DIP],obj); + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_DIP],obj); i++; break; } + /* 2dip */ else if(jit_fast_2dip_p(untag_object(array),i)) { - jit_compile(obj,relocate); - jit_emit_with(&jit,userenv[JIT_2DIP],obj); + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_2DIP],obj); i++; break; } + /* 3dip */ else if(jit_fast_3dip_p(untag_object(array),i)) { - jit_compile(obj,relocate); - jit_emit_with(&jit,userenv[JIT_3DIP],obj); + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_3DIP],obj); i++; break; } case ARRAY_TYPE: + /* Jump tables */ if(jit_fast_dispatch_p(untag_object(array),i)) { - EMIT_TAIL_CALL; - jit_emit_with(&jit,userenv[JIT_DISPATCH],obj); + TAIL_CALL; + jit_emit_with(jit,userenv[JIT_DISPATCH],obj); i++; break; } + /* Non-optimizing compiler ignores declarations */ else if(jit_ignore_declare_p(untag_object(array),i)) { i++; break; } + /* Method dispatch */ else if(jit_mega_lookup_p(untag_object(array),i)) { - jit_emit_mega_cache_lookup(&jit, + jit_emit_mega_cache_lookup(jit, array_nth(untag_object(array),i), untag_fixnum_fast(array_nth(untag_object(array),i + 1)), array_nth(untag_object(array),i + 2)); @@ -277,7 +275,7 @@ void jit_compile(CELL quot, bool relocate) break; } default: - jit_push(&jit,obj); + jit_push(jit,obj); break; } @@ -286,16 +284,47 @@ void jit_compile(CELL quot, bool relocate) if(!tail_call) { + jit_set_position(jit,length); + if(stack_frame) - jit_emit(&jit,userenv[JIT_EPILOG]); - jit_emit(&jit,userenv[JIT_RETURN]); + jit_emit(jit,userenv[JIT_EPILOG]); + jit_emit(jit,userenv[JIT_RETURN]); } + UNREGISTER_ROOT(array); +} + +void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) +{ + if(code->block.type != QUOTATION_TYPE) + critical_error("Bad param to set_quot_xt",(CELL)code); + + quot->code = code; + quot->xt = (XT)(code + 1); + quot->compiledp = T; +} + +/* Allocates memory */ +void jit_compile(CELL quot, bool relocate) +{ + if(untag_quotation(quot)->compiledp != F) + return; + + CELL array = untag_quotation(quot)->array; + + REGISTER_ROOT(quot); + REGISTER_ROOT(array); + + F_JIT jit; + jit_init(&jit,QUOTATION_TYPE,quot); + + jit_iterate_quotation(&jit,array,true,relocate); + F_CODE_BLOCK *compiled = jit_make_code_block(&jit); + set_quot_xt(untag_object(quot),compiled); - if(relocate) - relocate_code_block(compiled); + if(relocate) relocate_code_block(compiled); jit_dispose(&jit); @@ -303,134 +332,20 @@ void jit_compile(CELL quot, bool relocate) UNREGISTER_ROOT(quot); } -/* Crappy code duplication. If C had closures (not just function pointers) -it would be easy to get rid of, but I can't think of a good way to deal -with it right now that doesn't involve lots of boilerplate that would be -worse than the duplication itself (eg, putting all state in some global -struct.) */ -#define COUNT(name,scan) \ - { \ - CELL size = array_capacity(code_to_emit(name)); \ - if(offset == 0) return scan - 1; \ - if(offset < size) return scan + 1; \ - offset -= size; \ - } - -#define COUNT_TAIL_CALL(name,scan) { \ - if(stack_frame) COUNT(userenv[JIT_EPILOG],scan) \ - tail_call = true; \ - COUNT(name,scan); \ - } - -F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) +F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset) { CELL array = untag_quotation(quot)->array; + REGISTER_ROOT(array); - bool stack_frame = jit_stack_frame_p(untag_object(array)); + F_JIT jit; + jit_init(&jit,QUOTATION_TYPE,quot); + jit_compute_position(&jit,offset); + jit_iterate_quotation(&jit,array,false,false); + jit_dispose(&jit); - if(stack_frame) - COUNT(userenv[JIT_PROLOG],0) + UNREGISTER_ROOT(array); - CELL i; - CELL length = array_capacity(untag_object(array)); - bool tail_call = false; - - for(i = 0; i < length; i++) - { - CELL obj = array_nth(untag_object(array),i); - F_WORD *word; - - switch(type_of(obj)) - { - case WORD_TYPE: - word = untag_object(obj); - if(word->subprimitive != F) - COUNT(word->subprimitive,i) - else if(obj == userenv[JIT_EXECUTE_WORD]) - { - if(i == length - 1) - COUNT_TAIL_CALL(userenv[JIT_EXECUTE_JUMP],i) - else - COUNT(userenv[JIT_EXECUTE_CALL],i) - } - else if(i == length - 1) - COUNT_TAIL_CALL(userenv[JIT_WORD_JUMP],i) - else - COUNT(userenv[JIT_WORD_CALL],i) - break; - case WRAPPER_TYPE: - COUNT(userenv[JIT_PUSH_IMMEDIATE],i) - break; - case FIXNUM_TYPE: - if(jit_primitive_call_p(untag_object(array),i)) - { - COUNT(userenv[JIT_SAVE_STACK],i); - COUNT(userenv[JIT_PRIMITIVE],i); - - i++; - - tail_call = true; - break; - } - case QUOTATION_TYPE: - if(jit_fast_if_p(untag_object(array),i)) - { - if(stack_frame) - COUNT(userenv[JIT_EPILOG],i) - tail_call = true; - - COUNT(userenv[JIT_IF_1],i) - COUNT(userenv[JIT_IF_2],i) - i += 2; - - break; - } - else if(jit_fast_dip_p(untag_object(array),i)) - { - COUNT(userenv[JIT_DIP],i) - i++; - break; - } - else if(jit_fast_2dip_p(untag_object(array),i)) - { - COUNT(userenv[JIT_2DIP],i) - i++; - break; - } - else if(jit_fast_3dip_p(untag_object(array),i)) - { - COUNT(userenv[JIT_3DIP],i) - i++; - break; - } - case ARRAY_TYPE: - if(jit_fast_dispatch_p(untag_object(array),i)) - { - i++; - COUNT_TAIL_CALL(userenv[JIT_DISPATCH],i) - break; - } - if(jit_ignore_declare_p(untag_object(array),i)) - { - if(offset == 0) return i; - i++; - break; - } - default: - COUNT(userenv[JIT_PUSH_IMMEDIATE],i) - break; - } - } - - if(!tail_call) - { - if(stack_frame) - COUNT(userenv[JIT_EPILOG],length) - - COUNT(userenv[JIT_RETURN],length) - } - - return -1; + return jit_get_position(&jit); } F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) diff --git a/vm/quotations.h b/vm/quotations.h index 16ef9df422..6509dfe5ed 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -8,7 +8,7 @@ INLINE CELL tag_quotation(F_QUOTATION *quotation) void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); -F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); +F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); void primitive_array_to_quotation(void); void primitive_quotation_xt(void); void primitive_jit_compile(void); From 742d574162cc96087a923bfa1088629c14c22942 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 19:42:08 -0500 Subject: [PATCH 78/83] Non-optimizing compiler doesn't need to optimize 'dispatch' primitive anymore since its rarely used --- basis/bootstrap/image/image.factor | 11 --------- basis/cpu/ppc/bootstrap.factor | 19 +++------------- basis/cpu/x86/bootstrap.factor | 18 --------------- vm/quotations.c | 36 ++++-------------------------- vm/run.h | 7 ++---- 5 files changed, 9 insertions(+), 82 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index fe1677a7a0..cad40b6384 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -144,8 +144,6 @@ SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-1 SYMBOL: jit-if-2 -SYMBOL: jit-dispatch-word -SYMBOL: jit-dispatch SYMBOL: jit-dip-word SYMBOL: jit-dip SYMBOL: jit-2dip-word @@ -158,7 +156,6 @@ SYMBOL: jit-execute-call SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling -SYMBOL: jit-declare-word SYMBOL: jit-save-stack ! PIC stubs @@ -192,13 +189,10 @@ SYMBOL: undefined-quot { jit-if-word 28 } { jit-if-1 29 } { jit-if-2 30 } - { jit-dispatch-word 31 } - { jit-dispatch 32 } { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-declare-word 37 } { jit-save-stack 38 } { jit-dip-word 39 } { jit-dip 40 } @@ -524,9 +518,7 @@ M: quotation ' : emit-jit-data ( -- ) \ if jit-if-word set - \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set - \ declare jit-declare-word set \ dip jit-dip-word set \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set @@ -545,8 +537,6 @@ M: quotation ' jit-if-word jit-if-1 jit-if-2 - jit-dispatch-word - jit-dispatch jit-dip-word jit-dip jit-2dip-word @@ -559,7 +549,6 @@ M: quotation ' jit-epilog jit-return jit-profiling - jit-declare-word jit-save-stack pic-load pic-tag diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 1f86bf6a0d..7278fd2092 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -74,21 +74,6 @@ CONSTANT: rs-reg 30 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-if-2 jit-define -: jit-jump-quot ( -- ) - 4 3 quot-xt-offset LWZ - 4 MTCTR - BCTR ; - -[ - 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 6 ds-reg 0 LWZ - 6 6 1 SRAWI - 3 3 6 ADD - 3 3 array-start-offset LWZ - ds-reg dup 4 SUBI - jit-jump-quot -] jit-dispatch jit-define - : jit->r ( -- ) 4 ds-reg 0 LWZ ds-reg dup 4 SUBI @@ -167,7 +152,9 @@ CONSTANT: rs-reg 30 [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - jit-jump-quot + 4 3 quot-xt-offset LWZ + 4 MTCTR + BCTR ] \ (call) define-sub-primitive [ diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 337c3ae575..4fe5e5cd33 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -65,24 +65,6 @@ big-endian off f JMP rc-relative rt-xt jit-rel ] jit-if-2 jit-define -[ - ! load dispatch table - temp1 0 MOV rc-absolute-cell rt-immediate jit-rel - ! load index - temp0 ds-reg [] MOV - ! turn it into an array offset - fixnum>slot@ - ! pop index - ds-reg bootstrap-cell SUB - ! compute quotation location - temp0 temp1 ADD - ! load quotation - arg temp0 array-start-offset [+] MOV - ! execute branch. the quot must be in arg, since it might - ! not be compiled yet - arg quot-xt-offset [+] JMP -] jit-dispatch jit-define - : jit->r ( -- ) rs-reg bootstrap-cell ADD temp0 ds-reg [] MOV diff --git a/vm/quotations.c b/vm/quotations.c index 909bba501e..2e0d5ed248 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -53,13 +53,6 @@ static bool jit_fast_if_p(F_ARRAY *array, CELL i) && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; } -static bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) -{ - return (i + 2) == array_capacity(array) - && type_of(array_nth(array,i)) == ARRAY_TYPE - && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; -} - static bool jit_fast_dip_p(F_ARRAY *array, CELL i) { return (i + 2) <= array_capacity(array) @@ -81,13 +74,6 @@ static bool jit_fast_3dip_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; } -static bool jit_ignore_declare_p(F_ARRAY *array, CELL i) -{ - return (i + 1) < array_capacity(array) - && type_of(array_nth(array,i)) == ARRAY_TYPE - && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; -} - static bool jit_mega_lookup_p(F_ARRAY *array, CELL i) { return (i + 3) < array_capacity(array) @@ -108,7 +94,7 @@ static bool jit_stack_frame_p(F_ARRAY *array) if(type_of(obj) == WORD_TYPE) { F_WORD *word = untag_object(obj); - if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD]) + if(word->subprimitive == F) return true; } else if(type_of(obj) == QUOTATION_TYPE) @@ -190,6 +176,7 @@ static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL r jit_push(jit,wrapper->object); break; case FIXNUM_TYPE: + /* Primitive calls */ if(jit_primitive_call_p(untag_object(array),i)) { jit_emit(jit,userenv[JIT_SAVE_STACK]); @@ -201,7 +188,7 @@ static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL r break; } case QUOTATION_TYPE: - /* if preceeded by two literal quotations (this is why if and ? are + /* 'if' preceeded by two literal quotations (this is why if and ? are mutually recursive in the library, but both still work) */ if(jit_fast_if_p(untag_object(array),i)) { @@ -248,23 +235,8 @@ static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL r break; } case ARRAY_TYPE: - /* Jump tables */ - if(jit_fast_dispatch_p(untag_object(array),i)) - { - TAIL_CALL; - jit_emit_with(jit,userenv[JIT_DISPATCH],obj); - - i++; - break; - } - /* Non-optimizing compiler ignores declarations */ - else if(jit_ignore_declare_p(untag_object(array),i)) - { - i++; - break; - } /* Method dispatch */ - else if(jit_mega_lookup_p(untag_object(array),i)) + if(jit_mega_lookup_p(untag_object(array),i)) { jit_emit_mega_cache_lookup(jit, array_nth(untag_object(array),i), diff --git a/vm/run.h b/vm/run.h index d32a91e67a..b31fc3a2e1 100755 --- a/vm/run.h +++ b/vm/run.h @@ -41,14 +41,11 @@ typedef enum { JIT_IF_WORD, JIT_IF_1, JIT_IF_2, - JIT_DISPATCH_WORD, - JIT_DISPATCH, - JIT_EPILOG, + JIT_EPILOG = 33, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DECLARE_WORD, - JIT_SAVE_STACK, + JIT_SAVE_STACK = 38, JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, From b20ed595c4df2e14f5bdc28381f66b1639d00d97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 19:47:08 -0500 Subject: [PATCH 79/83] Remove obsolete comment --- vm/quotations.c | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/vm/quotations.c b/vm/quotations.c index 2e0d5ed248..29ab8537d1 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -27,12 +27,7 @@ generated. 4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are open-coded as retain stack manipulation surrounding a subroutine call. -5) When preceded by an array, calls to the 'declare' word are optimized out -entirely. This word is only used by the optimizing compiler, and with the -non-optimizing compiler it would otherwise just decrease performance to have to -push the array and immediately drop it after. - -6) Sub-primitives are primitive words which are implemented in assembly and not +5) Sub-primitives are primitive words which are implemented in assembly and not in the VM. They are open-coded and no subroutine call is generated. This includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) From f51b7b26772310e2c87490ff034a96b802430c50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 20:03:52 -0500 Subject: [PATCH 80/83] Fix tools.time output in the TTY listener --- basis/io/styles/styles.factor | 6 +++++- basis/strings/tables/tables-tests.factor | 4 ++++ basis/strings/tables/tables.factor | 27 ++++++++++++++++-------- basis/tools/time/time.factor | 13 ++++++------ 4 files changed, 34 insertions(+), 16 deletions(-) diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index c3bf5d2f28..2d25016919 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -99,7 +99,11 @@ M: plain-writer make-block-stream nip ; M: plain-writer stream-write-table - [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ; + [ + drop + [ [ >string ] map ] map format-table + [ nl ] [ write ] interleave + ] with-output-stream* ; M: plain-writer make-cell-stream 2drop ; diff --git a/basis/strings/tables/tables-tests.factor b/basis/strings/tables/tables-tests.factor index a77312897a..9429772f4a 100644 --- a/basis/strings/tables/tables-tests.factor +++ b/basis/strings/tables/tables-tests.factor @@ -2,3 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test strings.tables ; IN: strings.tables.tests + +[ { "A BB" "CC D" } ] [ { { "A" "BB" } { "CC" "D" } } format-table ] unit-test + +[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test \ No newline at end of file diff --git a/basis/strings/tables/tables.factor b/basis/strings/tables/tables.factor index c6ccba5a78..51032264c7 100644 --- a/basis/strings/tables/tables.factor +++ b/basis/strings/tables/tables.factor @@ -1,21 +1,30 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences fry math.order ; +USING: kernel sequences fry math.order splitting ; IN: strings.tables ] dip '[ 0 = @ ] 2map ; inline +: max-length ( seq -- n ) + [ length ] [ max ] map-reduce ; + +: format-row ( seq ? -- seq ) + [ + dup max-length + '[ _ "" pad-tail ] map + ] unless ; + +: format-column ( seq ? -- seq ) + [ + dup max-length + '[ _ CHAR: \s pad-tail ] map + ] unless ; + PRIVATE> : format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; \ No newline at end of file + [ [ [ string-lines ] map ] dip format-row flip ] map-last concat + flip [ format-column ] map-last flip [ " " join ] map ; \ No newline at end of file diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 269581730b..65e87f976f 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -9,18 +9,19 @@ IN: tools.time micros [ call micros ] dip - ; inline : time. ( time -- ) - "== Running time ==" print nl 1000000 /f pprint " seconds" write ; + "== Running time ==" print nl 1000000 /f pprint " seconds" print ; : gc-stats. ( stats -- ) 5 cut* "== Garbage collection ==" print nl + "Times are in microseconds." print nl [ 6 group { "GC count:" - "Cumulative GC time (us):" - "Longest GC pause (us):" - "Average GC pause (us):" + "Total GC time:" + "Longest GC pause:" + "Average GC pause:" "Objects copied:" "Bytes copied:" } prefix @@ -31,10 +32,10 @@ IN: tools.time [ nl { - "Total GC time (us):" + "Total GC time:" "Cards scanned:" "Decks scanned:" - "Card scan time (us):" + "Card scan time:" "Code heap literal scans:" } swap zip simple-table. ] bi* ; From 10e21bf8d3fb4df59cc9c3a9acea08a758432521 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 20:35:55 -0500 Subject: [PATCH 81/83] tools.deploy.shaker: update for method dispatch changes --- basis/tools/deploy/shaker/shaker.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 9d489cb9a8..9b02d3208f 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -103,6 +103,7 @@ IN: tools.deploy.shaker "compiled-uses" "constraints" "custom-inlining" + "decision-tree" "declared-effect" "default" "default-method" @@ -112,14 +113,12 @@ IN: tools.deploy.shaker "engines" "forgotten" "identities" - "if-intrinsics" - "infer" "inline" "inlined-block" "input-classes" "instances" "interval" - "intrinsics" + "intrinsic" "lambda" "loc" "local-reader" @@ -136,7 +135,7 @@ IN: tools.deploy.shaker "method-generic" "modular-arithmetic" "no-compile" - "optimizer-hooks" + "owner-generic" "outputs" "participants" "predicate" @@ -149,17 +148,13 @@ IN: tools.deploy.shaker "register" "register-size" "shuffle" - "slot-names" "slots" "special" "specializer" - "step-into" - "step-into?" ! UI needs this ! "superclass" "transform-n" "transform-quot" - "tuple-dispatch-generic" "type" "writer" "writing" From a79e3eb6878534a3cf52eee2317e52e091de20db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 20:40:47 -0500 Subject: [PATCH 82/83] Passing an invalid parameter to 'declare' doesn't break the compiler anymore --- basis/compiler/tests/optimizer.factor | 8 +++++++- basis/hints/hints.factor | 2 +- basis/stack-checker/errors/errors.factor | 2 ++ basis/stack-checker/known-words/known-words.factor | 8 ++++++-- 4 files changed, 16 insertions(+), 4 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index d051031d4a..f19a950711 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep -compiler ; +compiler definitions ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -384,3 +384,9 @@ DEFER: loop-bbb 1 >bignum 2 >bignum [ { bignum integer } declare [ shift ] keep 1+ ] compile-call ] unit-test + +: broken-declaration ( -- ) \ + declare ; + +[ f ] [ \ broken-declaration optimized? ] unit-test + +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test \ No newline at end of file diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d83275c750..db04033275 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -71,7 +71,7 @@ t specialize-method? set-global SYNTAX: HINTS: scan-object [ changed-definition ] - [ parse-definition "specializer" set-word-prop ] bi ; + [ parse-definition { } like "specializer" set-word-prop ] bi ; ! Default specializers { first first2 first3 first4 } diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index e036d4d81b..b1071df708 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -33,4 +33,6 @@ ERROR: unknown-primitive-error < inference-error ; ERROR: transform-expansion-error < inference-error word error ; +ERROR: bad-declaration-error < inference-error declaration ; + M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 72eead1826..d7acf77162 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -10,7 +10,7 @@ sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions assocs summary compiler.units system.private -combinators locals locals.backend locals.types +combinators combinators.short-circuit locals locals.backend locals.types quotations.private combinators.private stack-checker.values generic.single generic.single.private alien.libraries @@ -58,8 +58,12 @@ IN: stack-checker.known-words : infer-shuffle-word ( word -- ) "shuffle" word-prop infer-shuffle ; +: check-declaration ( declaration -- declaration ) + dup { [ array? ] [ [ class? ] all? ] } 1&& + [ bad-declaration-error ] unless ; + : infer-declare ( -- ) - pop-literal nip + pop-literal nip check-declaration [ length ensure-d ] keep zip #declare, ; From e5cdb7ac2db9a7f0fa95aafc06fcd2d903ea6923 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 21:08:29 -0500 Subject: [PATCH 83/83] call( fast-path now supports curry and compose --- basis/compiler/tests/call-effect.factor | 7 +++++ .../tree/propagation/inlining/inlining.factor | 4 +-- .../call-effect/call-effect-tests.factor | 13 +++++++-- .../call-effect/call-effect.factor | 28 +++++++++++++++++-- .../known-words/known-words.factor | 2 +- basis/stack-checker/stack-checker-docs.factor | 1 + core/effects/effects-docs.factor | 11 ++++++-- core/effects/effects-tests.factor | 6 +++- core/effects/effects.factor | 20 +++++++++++-- 9 files changed, 78 insertions(+), 14 deletions(-) create mode 100644 basis/compiler/tests/call-effect.factor diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor new file mode 100644 index 0000000000..407250a685 --- /dev/null +++ b/basis/compiler/tests/call-effect.factor @@ -0,0 +1,7 @@ +IN: compiler.tests.call-effect +USING: tools.test combinators generic.single sequences kernel ; + +: execute-ic-test ( a b -- c ) execute( a -- c ) ; + +! VM type check error +[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 42c47377e0..2a7d431314 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -188,9 +188,7 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] - [ "default" word-prop ] - [ { call execute } memq? ] tri or or ; + [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor index e5c0f23b30..b222cbbcf7 100644 --- a/basis/stack-checker/call-effect/call-effect-tests.factor +++ b/basis/stack-checker/call-effect/call-effect-tests.factor @@ -1,7 +1,16 @@ -USING: stack-checker.call-effect tools.test math kernel ; +USING: stack-checker.call-effect tools.test math kernel math effects ; IN: stack-checker.call-effect.tests [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test [ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test [ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test -[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test + +[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test +[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test +[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test +[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test +[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test +[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test +[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test +[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index daeecc3ad5..4adc5952fd 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -stack-checker stack-checker.transforms words ; +stack-checker stack-checker.transforms words math ; IN: stack-checker.call-effect ! call( and execute( have complex expansions. @@ -18,14 +18,36 @@ IN: stack-checker.call-effect TUPLE: inline-cache value ; -: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline +: cache-hit? ( word/quot ic -- ? ) + [ value>> ] [ value>> eq? ] bi and ; inline -SYMBOL: +unknown+ +SINGLETON: +unknown+ GENERIC: cached-effect ( quot -- effect ) M: object cached-effect drop +unknown+ ; +GENERIC: curry-effect ( effect -- effect' ) + +M: +unknown+ curry-effect ; + +M: effect curry-effect + [ in>> length ] [ out>> length ] [ terminated?>> ] tri + pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if + effect boa ; + +M: curry cached-effect + quot>> cached-effect curry-effect ; + +: compose-effects* ( effect1 effect2 -- effect' ) + { + { [ 2dup [ effect? ] both? ] [ compose-effects ] } + { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] } + } cond ; + +M: compose cached-effect + [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ; + M: quotation cached-effect dup cached-effect>> [ ] [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index d7acf77162..4a9ff93179 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -147,7 +147,7 @@ M: object infer-call* apply-word/effect ; : infer-execute-effect-unsafe ( -- ) - \ execute infer-effect-unsafe ; + \ (execute) infer-effect-unsafe ; : infer-call-effect-unsafe ( -- ) \ call infer-effect-unsafe ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 243221ccf0..7d18482bff 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -102,6 +102,7 @@ ARTICLE: "tools.inference" "Stack effect tools" "Comparing effects:" { $subsection effect-height } { $subsection effect<= } +{ $subsection effect= } "The class of stack effects:" { $subsection effect } { $subsection effect? } ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 495aeb39c1..38b8ab4dad 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -42,8 +42,15 @@ HELP: effect-height { $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ; HELP: effect<= -{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; + +HELP: effect= +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." } +{ $examples + { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" } +} ; HELP: effect>string { $values { "obj" object } { "str" string } } diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 316add54c0..3eb9273859 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -18,4 +18,8 @@ USING: effects tools.test prettyprint accessors sequences ; [ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test [ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test -[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test \ No newline at end of file +[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test + +[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test +[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test +[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test \ No newline at end of file diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 142b9120a8..cab1e531b7 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser namespaces make sequences strings +USING: kernel math math.parser math.order namespaces make sequences strings words assocs combinators accessors arrays ; IN: effects @@ -13,7 +13,7 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; : effect-height ( effect -- n ) [ out>> length ] [ in>> length ] bi - ; inline -: effect<= ( eff1 eff2 -- ? ) +: effect<= ( effect1 effect2 -- ? ) { { [ over terminated?>> ] [ t ] } { [ dup terminated?>> ] [ f ] } @@ -22,6 +22,12 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; [ t ] } cond 2nip ; inline +: effect= ( effect1 effect2 -- ? ) + [ [ in>> length ] bi@ = ] + [ [ out>> length ] bi@ = ] + [ [ terminated?>> ] bi@ = ] + 2tri and and ; + GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: object effect>string drop "object" ; @@ -66,3 +72,13 @@ M: effect clone : add-effect-input ( effect -- effect' ) [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ; + +: compose-effects ( effect1 effect2 -- effect' ) + over terminated?>> [ + drop + ] [ + [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ] + [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] + [ nip terminated?>> ] 2tri + effect boa + ] if ; inline