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 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 ; 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 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 ; 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/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 } } 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);