From 799f761befcf2ca3dac3d73a4dfa4996c59bc3c0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:31:40 -0600 Subject: [PATCH 1/6] state-tables vocab is no longer necessary --- basis/state-tables/authors.txt | 1 - basis/state-tables/state-tables-tests.factor | 56 --------- basis/state-tables/state-tables.factor | 123 ------------------- 3 files changed, 180 deletions(-) delete mode 100644 basis/state-tables/authors.txt delete mode 100644 basis/state-tables/state-tables-tests.factor delete mode 100644 basis/state-tables/state-tables.factor diff --git a/basis/state-tables/authors.txt b/basis/state-tables/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/basis/state-tables/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/state-tables/state-tables-tests.factor b/basis/state-tables/state-tables-tests.factor deleted file mode 100644 index b86c4f57d9..0000000000 --- a/basis/state-tables/state-tables-tests.factor +++ /dev/null @@ -1,56 +0,0 @@ -USING: kernel state-tables tools.test ; -IN: state-tables.tests - -: test-table - - "a" "c" "z" over set-entry - "a" "o" "y" over set-entry - "a" "l" "x" over set-entry - "b" "o" "y" over set-entry - "b" "l" "x" over set-entry - "b" "s" "u" over set-entry ; - -[ - T{ - table - f - H{ - { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } } - { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } } - } - H{ { "l" t } { "s" t } { "c" t } { "o" t } } - f - H{ } - } -] [ test-table ] unit-test - -[ "x" t ] [ "a" "l" test-table get-entry ] unit-test -[ "har" t ] [ - "a" "z" "har" test-table [ set-entry ] keep - >r "a" "z" r> get-entry -] unit-test - -: vector-test-table - - "a" "c" "z" over add-entry - "a" "c" "r" over add-entry - "a" "o" "y" over add-entry - "a" "l" "x" over add-entry - "b" "o" "y" over add-entry - "b" "l" "x" over add-entry - "b" "s" "u" over add-entry ; - -[ -T{ vector-table f - H{ - { "a" - H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } } - { "b" - H{ { "l" "x" } { "s" "u" } { "o" "y" } } } - } - H{ { "l" t } { "s" t } { "c" t } { "o" t } } - f - H{ } -} -] [ vector-test-table ] unit-test - diff --git a/basis/state-tables/state-tables.factor b/basis/state-tables/state-tables.factor deleted file mode 100644 index ecb258c163..0000000000 --- a/basis/state-tables/state-tables.factor +++ /dev/null @@ -1,123 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make sequences vectors assocs accessors ; -IN: state-tables - -TUPLE: table rows columns start-state final-states ; -TUPLE: entry row-key column-key value ; - -GENERIC: add-entry ( entry table -- ) - -: make-table ( class -- obj ) - new - H{ } clone >>rows - H{ } clone >>columns - H{ } clone >>final-states ; - -:
( -- obj ) - table make-table ; - -C: entry - -: (add-row) ( row-key table -- row ) - 2dup rows>> at* [ - 2nip - ] [ - drop H{ } clone [ -rot rows>> set-at ] keep - ] if ; - -: add-row ( row-key table -- ) - (add-row) drop ; - -: add-column ( column-key table -- ) - t -rot columns>> set-at ; - -: set-row ( row row-key table -- ) - rows>> set-at ; - -: lookup-row ( row-key table -- row/f ? ) - rows>> at* ; - -: row-exists? ( row-key table -- ? ) - lookup-row nip ; - -: lookup-column ( column-key table -- column/f ? ) - columns>> at* ; - -: column-exists? ( column-key table -- ? ) - lookup-column nip ; - -ERROR: no-row key ; -ERROR: no-column key ; - -: get-row ( row-key table -- row ) - dupd lookup-row [ - nip - ] [ - drop no-row - ] if ; - -: get-column ( column-key table -- column ) - dupd lookup-column [ - nip - ] [ - drop no-column - ] if ; - -: get-entry ( row-key column-key table -- obj ? ) - swapd lookup-row [ - at* - ] [ - 2drop f f - ] if ; - -: (set-entry) ( entry table -- value column-key row ) - [ >r column-key>> r> add-column ] 2keep - dupd >r row-key>> r> (add-row) - >r [ value>> ] keep column-key>> r> ; - -: set-entry ( entry table -- ) - (set-entry) set-at ; - -: delete-entry ( entry table -- ) - >r [ column-key>> ] [ row-key>> ] bi r> - lookup-row [ delete-at ] [ 2drop ] if ; - -: swap-rows ( row-key1 row-key2 table -- ) - [ tuck get-row >r get-row r> ] 3keep - >r >r rot r> r> [ set-row ] keep set-row ; - -: member?* ( obj obj -- bool ) - 2dup = [ 2drop t ] [ member? ] if ; - -: find-by-column ( column-key data table -- seq ) - swapd 2dup lookup-column 2drop - [ - rows>> [ - pick swap at* [ - >r pick r> member?* [ , ] [ drop ] if - ] [ - 2drop - ] if - ] assoc-each - ] { } make 2nip ; - - -TUPLE: vector-table < table ; -: ( -- obj ) - vector-table make-table ; - -: add-hash-vector ( value key hash -- ) - 2dup at* [ - dup vector? [ - 2nip push - ] [ - V{ } clone [ push ] keep - -rot >r >r [ push ] keep r> r> set-at - ] if - ] [ - drop set-at - ] if ; - -M: vector-table add-entry ( entry table -- ) - (set-entry) add-hash-vector ; From 87bdc0acd3a3a65dfb9b1802148355768ca8053a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:57:26 -0600 Subject: [PATCH 2/6] if we're on win64, don't run postgresql tests --- basis/db/postgresql/postgresql-tests.factor | 150 ++++++++++---------- basis/db/tuples/tuples-tests.factor | 6 +- 2 files changed, 80 insertions(+), 76 deletions(-) diff --git a/basis/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor index fe53e2416e..bc5ec2f0c5 100644 --- a/basis/db/postgresql/postgresql-tests.factor +++ b/basis/db/postgresql/postgresql-tests.factor @@ -1,6 +1,6 @@ USING: kernel db.postgresql alien continuations io classes prettyprint sequences namespaces tools.test db -db.tuples db.types unicode.case accessors ; +db.tuples db.types unicode.case accessors system ; IN: db.postgresql.tests : test-db ( -- postgresql-db ) @@ -10,86 +10,88 @@ IN: db.postgresql.tests "thepasswordistrust" >>password "factor-test" >>database ; -[ ] [ test-db [ ] with-db ] unit-test +os windows? cpu x86.64? and [ + [ ] [ test-db [ ] with-db ] unit-test -[ ] [ - test-db [ - [ "drop table person;" sql-command ] ignore-errors - "create table person (name varchar(30), country varchar(30));" + [ ] [ + test-db [ + [ "drop table person;" sql-command ] ignore-errors + "create table person (name varchar(30), country varchar(30));" + sql-command + + "insert into person values('John', 'America');" sql-command + "insert into person values('Jane', 'New Zealand');" sql-command + ] with-db + ] unit-test + + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + } + ] [ + test-db [ + "select * from person" sql-query + ] with-db + ] unit-test + + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + } + ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + + [ + ] [ + test-db [ + "insert into person(name, country) values('Jimmy', 'Canada')" sql-command + ] with-db + ] unit-test - "insert into person values('John', 'America');" sql-command - "insert into person values('Jane', 'New Zealand');" sql-command - ] with-db -] unit-test + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + { "Jimmy" "Canada" } + } + ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ - test-db [ - "select * from person" sql-query - ] with-db -] unit-test + [ + test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "oops" throw + ] with-transaction + ] with-db + ] must-fail -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + [ 3 ] [ + test-db [ + "select * from person" sql-query length + ] with-db + ] unit-test -[ -] [ - test-db [ - "insert into person(name, country) values('Jimmy', 'Canada')" - sql-command - ] with-db -] unit-test + [ + ] [ + test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + ] with-transaction + ] with-db + ] unit-test -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - { "Jimmy" "Canada" } - } -] [ test-db [ "select * from person" sql-query ] with-db ] unit-test - -[ - test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "oops" throw - ] with-transaction - ] with-db -] must-fail - -[ 3 ] [ - test-db [ - "select * from person" sql-query length - ] with-db -] unit-test - -[ -] [ - test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - ] with-transaction - ] with-db -] unit-test - -[ 5 ] [ - test-db [ - "select * from person" sql-query length - ] with-db -] unit-test + [ 5 ] [ + test-db [ + "select * from person" sql-query length + ] with-db + ] unit-test +] unless : with-dummy-db ( quot -- ) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 192986484e..0432f38683 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitwise +db.postgresql accessors random math.bitwise system math.ranges strings urls fry db.tuples.private ; IN: db.tuples.tests @@ -26,7 +26,9 @@ IN: db.tuples.tests : test-postgresql ( quot -- ) '[ - [ ] [ postgresql-db _ with-db ] unit-test + os windows? cpu x86.64? and [ + [ ] [ postgresql-db _ with-db ] unit-test + ] unless ] call ; inline ! These words leak resources, but are useful for interactivel testing From f8a23c657bc10c03a9dd8489246f1593d1d31934 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:59:29 -0600 Subject: [PATCH 3/6] a bit of refactoring, preparing to take options out of the parsing stage --- basis/regexp/backend/backend.factor | 2 +- basis/regexp/nfa/nfa.factor | 29 ++++++++++++------- basis/regexp/parser/parser.factor | 22 +++++++------- .../transition-tables.factor | 5 ++-- basis/regexp/traversal/traversal.factor | 3 ++ 5 files changed, 37 insertions(+), 24 deletions(-) diff --git a/basis/regexp/backend/backend.factor b/basis/regexp/backend/backend.factor index 75a010b705..4c82876650 100644 --- a/basis/regexp/backend/backend.factor +++ b/basis/regexp/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors hashtables kernel math state-tables vectors ; +USING: accessors hashtables kernel math vectors ; IN: regexp.backend TUPLE: regexp diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 50847d6ff9..99d94b4bcb 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs grouping kernel regexp.backend -locals math namespaces regexp.parser sequences state-tables fry -quotations math.order math.ranges vectors unicode.categories -regexp.utils regexp.transition-tables words sets ; +locals math namespaces regexp.parser sequences fry quotations +math.order math.ranges vectors unicode.categories regexp.utils +regexp.transition-tables words sets ; IN: regexp.nfa SYMBOL: negation-mode @@ -22,6 +22,9 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag +: add-global-flag ( flag -- ) + current-regexp get nfa-table>> flags>> conjoin ; + : next-state ( regexp -- state ) [ state>> ] [ [ 1+ ] change-state drop ] bi ; @@ -138,21 +141,25 @@ M: non-capture-group nfa-node ( node -- ) M: reluctant-kleene-star nfa-node ( node -- ) term>> nfa-node ; - -: add-epsilon-flag ( flag -- ) - eps literal-transition add-simple-entry add-traversal-flag ; - M: beginning-of-line nfa-node ( node -- ) - drop beginning-of-line add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + beginning-of-line add-global-flag ; M: end-of-line nfa-node ( node -- ) - drop end-of-line add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + end-of-line add-global-flag ; M: beginning-of-input nfa-node ( node -- ) - drop beginning-of-input add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + beginning-of-input add-global-flag ; M: end-of-input nfa-node ( node -- ) - drop end-of-input add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + end-of-input add-global-flag ; M: negation nfa-node ( node -- ) negation-mode inc diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index ea8aaffcd5..71a3e067f3 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -58,7 +58,7 @@ SINGLETONS: letter-class LETTER-class Letter-class digit-class alpha-class non-newline-blank-class ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class -terminator-class unmatchable-class word-boundary-class ; +unmatchable-class terminator-class word-boundary-class ; SINGLETONS: beginning-of-group end-of-group beginning-of-character-class end-of-character-class @@ -87,8 +87,8 @@ left-parenthesis pipe caret dash ; : ( obj -- kleene-star ) kleene-star boa ; : ( obj -- constant ) dup Letter? get-case-insensitive and [ - [ ch>lower constant boa ] - [ ch>upper constant boa ] bi 2array + [ ch>lower ] [ ch>upper ] bi + [ constant boa ] bi@ 2array ] [ constant boa ] if ; @@ -384,20 +384,22 @@ DEFER: handle-left-bracket } case [ (parse-character-class) ] when ; +: push-constant ( ch -- ) push-stack ; + : parse-character-class-second ( -- ) read1 { - { CHAR: [ [ CHAR: [ push-stack ] } - { CHAR: ] [ CHAR: ] push-stack ] } - { CHAR: - [ CHAR: - push-stack ] } + { CHAR: [ [ CHAR: [ push-constant ] } + { CHAR: ] [ CHAR: ] push-constant ] } + { CHAR: - [ CHAR: - push-constant ] } [ push1 ] } case ; : parse-character-class-first ( -- ) read1 { { CHAR: ^ [ caret push-stack parse-character-class-second ] } - { CHAR: [ [ CHAR: [ push-stack ] } - { CHAR: ] [ CHAR: ] push-stack ] } - { CHAR: - [ CHAR: - push-stack ] } + { CHAR: [ [ CHAR: [ push-constant ] } + { CHAR: ] [ CHAR: ] push-constant ] } + { CHAR: - [ CHAR: - push-constant ] } [ push1 ] } case ; @@ -431,7 +433,7 @@ DEFER: handle-left-bracket drop handle-back-anchor f ] [ - push-stack t + push-constant t ] if ] } case ; diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 3050be14fa..80317a1b66 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -25,12 +25,13 @@ TUPLE: default ; : ( from to -- transition ) t default-transition make-transition ; -TUPLE: transition-table transitions start-state final-states ; +TUPLE: transition-table transitions start-state final-states flags ; : ( -- transition-table ) transition-table new H{ } clone >>transitions - H{ } clone >>final-states ; + H{ } clone >>final-states + H{ } clone >>flags ; : maybe-initialize-key ( key hashtable -- ) 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index c880c11c53..d8c25eda18 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -82,6 +82,7 @@ M: end-of-input flag-action ( dfa-traverser flag -- ) drop dup end-of-text? [ t >>match-failed? ] unless drop ; + M: beginning-of-line flag-action ( dfa-traverser flag -- ) drop dup { @@ -96,6 +97,7 @@ M: end-of-line flag-action ( dfa-traverser flag -- ) [ next-text-character terminator-class class-member? ] } 1|| [ t >>match-failed? ] unless drop ; + M: word-boundary flag-action ( dfa-traverser flag -- ) drop dup { @@ -103,6 +105,7 @@ M: word-boundary flag-action ( dfa-traverser flag -- ) [ current-text-character terminator-class class-member? ] } 1|| [ t >>match-failed? ] unless drop ; + M: lookahead-on flag-action ( dfa-traverser flag -- ) drop lookahead-counters>> 0 swap push ; From fbc0f33c86119b29492dea7562a5453b2aa1c994 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 15:59:27 -0600 Subject: [PATCH 4/6] The deploy tool would coalesce equal quotations into one. This created a problem for the non-optimizing compiler because if the new 'leader' quotation was not compiled but some of the ones that it replaces were, then calls to the quotation from contexts where they have to be compiled (eg, compiled if and dip) would no longer work. Add a `jit-compile' primitive to compile quotations, and call it as appropriate in `compress-quotations`. --- basis/tools/deploy/shaker/shaker.factor | 19 +++++++++++++------ core/bootstrap/primitives.factor | 1 + vm/cpu-arm.S | 2 +- vm/cpu-ppc.S | 2 +- vm/cpu-x86.S | 2 +- vm/primitives.c | 1 + vm/quotations.c | 7 ++++++- vm/quotations.h | 3 ++- 8 files changed, 26 insertions(+), 11 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 9cc5a66f70..a537d37d11 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -321,20 +321,27 @@ IN: tools.deploy.shaker ] with-compilation-unit ] unless ; -: compress ( pred string -- ) +: compress ( pred post-process string -- ) "Compressing " prepend show - instances - dup H{ } clone [ [ ] cache ] curry map + [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline : compress-byte-arrays ( -- ) - [ byte-array? ] "byte arrays" compress ; + [ byte-array? ] [ ] "byte arrays" compress ; + +: remain-compiled ( old new -- old new ) + #! Quotations which were formerly compiled must remain + #! compiled. + 2dup [ + 2dup [ compiled>> ] [ compiled>> not ] bi* and + [ nip jit-compile ] [ 2drop ] if + ] 2each ; : compress-quotations ( -- ) - [ quotation? ] "quotations" compress ; + [ quotation? ] [ remain-compiled ] "quotations" compress ; : compress-strings ( -- ) - [ string? ] "strings" compress ; + [ string? ] [ ] "strings" compress ; : finish-deploy ( final-image -- ) "Finishing up" show diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 962e562be5..4624963aa6 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,6 +533,7 @@ tuple { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } { "gc-reset" "memory" } + { "jit-compile" "quotations" } } [ [ first2 ] dip make-primitive ] each-index diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index d98c033a4f..09e3331b99 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -117,7 +117,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(void,lazy_jit_compile,(CELL quot)): mov r1,sp /* save stack pointer */ PROLOGUE - bl MANGLE(primitive_jit_compile) + bl MANGLE(lazy_jit_compile_impl) EPILOGUE JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 620bc9e991..e12707819a 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -165,7 +165,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(void,lazy_jit_compile,(CELL quot)): mr r4,r1 /* save stack pointer */ PROLOGUE - bl MANGLE(primitive_jit_compile) + bl MANGLE(lazy_jit_compile_impl) EPILOGUE JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 1857fb0ed8..4d6737baeb 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -27,7 +27,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ sub $STACK_PADDING,STACK_REG - call MANGLE(primitive_jit_compile) + call MANGLE(lazy_jit_compile_impl) mov RETURN_REG,ARG0 /* No-op on 32-bit */ add $STACK_PADDING,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ diff --git a/vm/primitives.c b/vm/primitives.c index 5adb135c82..a34d695bb8 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -140,4 +140,5 @@ void *primitives[] = { primitive_dll_validp, primitive_unimplemented, primitive_gc_reset, + primitive_jit_compile, }; diff --git a/vm/quotations.c b/vm/quotations.c index d8f1a3f61b..a187fecbbb 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -493,7 +493,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) return -1; } -F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) { stack_chain->callstack_top = stack; REGISTER_ROOT(quot); @@ -502,6 +502,11 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) return quot; } +void primitive_jit_compile(void) +{ + jit_compile(dpop(),true); +} + /* push a new quotation on the stack */ void primitive_array_to_quotation(void) { diff --git a/vm/quotations.h b/vm/quotations.h index 45bf78d14f..ff84977fd9 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,6 +1,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); -F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); +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); void primitive_array_to_quotation(void); void primitive_quotation_xt(void); +void primitive_jit_compile(void); From e9aa13150f18d5b4c96f28ef531970b3a94aba7f Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 16:01:53 -0600 Subject: [PATCH 5/6] gc-reset, gc-stats, jit-compile primitives didn't have static stack effects --- basis/stack-checker/known-words/known-words.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 986bbe4c72..6585698b23 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -614,3 +614,9 @@ M: object infer-call* \ modify-code-heap { array object } { } define-primitive \ unimplemented { } { } define-primitive + +\ gc-reset { } { } define-primitive + +\ gc-stats { } { array } define-primitive + +\ jit-compile { quotation } { } define-primitive From 0925bc7002c6d478a6251fde1b1d7c329a7a8760 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 16:02:07 -0600 Subject: [PATCH 6/6] Tweak hello-world deploy descriptor to reduce sizse --- extra/hello-world/deploy.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 219fe0ca05..62b7c2f180 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-name "Hello world (console)" } { deploy-threads? f } + { deploy-name "Hello world (console)" } + { deploy-word-defs? f } { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-io 2 } - { deploy-math? f } { deploy-ui? f } { deploy-compiler? f } + { deploy-io 2 } + { deploy-math? f } + { deploy-reflection 1 } + { deploy-unicode? f } { "stop-after-last-window?" t } - { deploy-word-defs? f } + { deploy-c-types? f } }