diff --git a/Makefile b/Makefile index 5f7cdca06d..769aeacb8c 100755 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ AR = ar LD = ld EXECUTABLE = factor -VERSION = 0.91 +VERSION = 0.92 IMAGE = factor.image BUNDLE = Factor.app diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 58ee77fafd..5812a0f8e7 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -8,7 +8,7 @@ grouping growable classes classes.builtin classes.tuple classes.tuple.private words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order accessors ; +io.encodings.binary math.order math.private accessors slots.private ; IN: bootstrap.image : my-arch ( -- arch ) @@ -75,7 +75,7 @@ SYMBOL: objects : data-base 1024 ; inline -: userenv-size 64 ; inline +: userenv-size 70 ; inline : header-size 10 ; inline @@ -118,6 +118,29 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling +SYMBOL: jit-tag +SYMBOL: jit-tag-word +SYMBOL: jit-eq? +SYMBOL: jit-eq?-word +SYMBOL: jit-slot +SYMBOL: jit-slot-word +SYMBOL: jit-declare-word +SYMBOL: jit-drop +SYMBOL: jit-drop-word +SYMBOL: jit-dup +SYMBOL: jit-dup-word +SYMBOL: jit->r +SYMBOL: jit->r-word +SYMBOL: jit-r> +SYMBOL: jit-r>-word +SYMBOL: jit-swap +SYMBOL: jit-swap-word +SYMBOL: jit-over +SYMBOL: jit-over-word +SYMBOL: jit-fixnum-fast +SYMBOL: jit-fixnum-fast-word +SYMBOL: jit-fixnum>= +SYMBOL: jit-fixnum>=-word ! Default definition for undefined words SYMBOL: undefined-quot @@ -140,7 +163,30 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } - { undefined-quot 37 } + { jit-tag 36 } + { jit-tag-word 37 } + { jit-eq? 38 } + { jit-eq?-word 39 } + { jit-slot 40 } + { jit-slot-word 41 } + { jit-declare-word 42 } + { jit-drop 43 } + { jit-drop-word 44 } + { jit-dup 45 } + { jit-dup-word 46 } + { jit->r 47 } + { jit->r-word 48 } + { jit-r> 49 } + { jit-r>-word 50 } + { jit-swap 51 } + { jit-swap-word 52 } + { jit-over 53 } + { jit-over-word 54 } + { jit-fixnum-fast 55 } + { jit-fixnum-fast-word 56 } + { jit-fixnum>= 57 } + { jit-fixnum>=-word 58 } + { undefined-quot 60 } } at header-size + ; : emit ( cell -- ) image get push ; @@ -414,6 +460,18 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set + \ tag jit-tag-word set + \ eq? jit-eq?-word set + \ slot jit-slot-word set + \ declare jit-declare-word set + \ drop jit-drop-word set + \ dup jit-dup-word set + \ >r jit->r-word set + \ r> jit-r>-word set + \ swap jit-swap-word set + \ over jit-over-word set + \ fixnum-fast jit-fixnum-fast-word set + \ fixnum>= jit-fixnum>=-word set [ undefined ] undefined-quot set { jit-code-format @@ -430,6 +488,29 @@ M: quotation ' jit-epilog jit-return jit-profiling + jit-tag + jit-tag-word + jit-eq? + jit-eq?-word + jit-slot + jit-slot-word + jit-declare-word + jit-drop + jit-drop-word + jit-dup + jit-dup-word + jit->r + jit->r-word + jit-r> + jit-r>-word + jit-swap + jit-swap-word + jit-over + jit-over-word + jit-fixnum-fast + jit-fixnum-fast-word + jit-fixnum>= + jit-fixnum>=-word undefined-quot } [ emit-userenv ] each ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 1076901678..2d2498a1c3 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -224,3 +224,6 @@ M: anonymous-union (flatten-class) dup num-tags get >= [ drop \ hi-tag tag-number ] when ] map prune ; + +: class-tag ( class -- tag/f ) + class-tags dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/compiler/tests/reload.factor b/core/compiler/tests/reload.factor index 1e31757fca..b2b65b5868 100644 --- a/core/compiler/tests/reload.factor +++ b/core/compiler/tests/reload.factor @@ -1,6 +1,6 @@ IN: compiler.tests USE: vocabs.loader -"parser" reload -"sequences" reload -"kernel" reload +! "parser" reload +! "sequences" reload +! "kernel" reload diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 312b952b84..386f1366fc 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; +: rs-reg ( -- reg ) EDI ; : fixnum>slot@ ( -- ) arg0 1 SAR ; : rex-length ( -- n ) 0 ; diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index d167c2882a..0c9ce92edf 100755 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; +: rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) ; : rex-length ( -- n ) 1 ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 011c27112e..bf176eebfa 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -74,6 +74,90 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +[ + arg1 ds-reg [] MOV ! load from stack + arg1 tag-mask get AND ! compute tag + arg1 tag-bits get SHL ! tag the tag + ds-reg [] arg1 MOV ! push to stack +] f f f jit-tag jit-define + +: jit-compare ( -- ) + arg1 0 MOV ! load t + arg1 dup [] MOV + temp-reg \ f tag-number MOV ! load f + arg0 ds-reg [] MOV ! load first value + ds-reg bootstrap-cell SUB ! adjust stack pointer + ds-reg [] arg0 CMP ! compare with second value + ; + +[ + jit-compare + arg1 temp-reg CMOVNE ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define + +[ + arg0 ds-reg [] MOV ! load slot number + ds-reg bootstrap-cell SUB ! adjust stack pointer + arg1 ds-reg [] MOV ! load object + fixnum>slot@ ! turn slot number into offset + arg1 tag-bits get SHR ! mask off tag + arg1 tag-bits get SHL + arg0 arg1 arg0 [+] MOV ! load slot value + ds-reg [] arg0 MOV ! push to stack +] f f f jit-slot jit-define + +[ + ds-reg bootstrap-cell SUB +] f f f jit-drop jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-dup jit-define + +[ + rs-reg bootstrap-cell ADD + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + rs-reg [] arg0 MOV +] f f f jit->r jit-define + +[ + ds-reg bootstrap-cell ADD + arg0 rs-reg [] MOV + rs-reg bootstrap-cell SUB + ds-reg [] arg0 MOV +] f f f jit-r> jit-define + +[ + arg0 ds-reg [] MOV + arg1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] arg0 MOV + ds-reg [] arg1 MOV +] f f f jit-swap jit-define + +[ + arg0 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-over jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + arg1 ds-reg [] MOV + arg1 arg0 SUB + ds-reg [] arg1 MOV +] f f f jit-fixnum-fast jit-define + +[ + jit-compare + arg1 temp-reg CMOVL ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define + [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame ] f f f jit-epilog jit-define diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 07d8d6fdad..e646010c4c 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -32,7 +32,7 @@ SYMBOL: compiling-loops ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start -: compiled-stack-traces? ( -- ? ) 36 getenv ; +: compiled-stack-traces? ( -- ? ) 59 getenv ; : begin-compiling ( word label -- ) H{ } clone compiling-loops set diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 550bab72f4..45b6640b3a 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -562,13 +562,10 @@ M: loc lazy-store 2drop t ] if ; -: class-tag ( class -- tag/f ) - dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ; - : class-matches? ( actual expected -- ? ) { { f [ drop t ] } - { known-tag [ class-tag >boolean ] } + { known-tag [ dup [ class-tag >boolean ] when ] } [ class<= ] } case ; @@ -639,7 +636,7 @@ PRIVATE> [ second template-matches? ] find nip ; : operand-tag ( operand -- tag/f ) - operand-class class-tag ; + operand-class dup [ class-tag ] when ; UNION: immediate fixnum POSTPONE: f ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index bdac7c1dfe..f60ee6d0d1 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -22,7 +22,11 @@ GENERIC: engine>quot ( engine -- quot ) : linear-dispatch-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ eq? ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; : split-methods ( assoc class -- first second ) diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index c1e72a65de..02a7af105f 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -44,7 +44,7 @@ C: hi-tag-dispatch-engine "type" word-prop num-tags get - ; : hi-tag-quot ( -- quot ) - [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ; + [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ; M: hi-tag-dispatch-engine engine>quot methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index cf2d50b6e2..6f1773a21f 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ; : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ; -: tuple-layout-superclasses ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 4 slot { array } declare ; inline +: tuple-layout-superclasses% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 4 slot { array } declare + ] % ; inline : tuple-dispatch-engine-body ( engine -- quot ) [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot ] [ [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot : >=-case-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ fixnum>= ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; -: tuple-layout-echelon ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 5 slot ; inline +: tuple-layout-echelon% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 5 slot + ] % ; inline M: tuple-dispatch-engine engine>quot [ picker % - [ tuple-layout-echelon ] % + tuple-layout-echelon% [ tuple assumed set echelons>> dup empty? [ diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 365d5b7c5d..de6d8519ca 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -58,7 +58,7 @@ M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; -: stderr-handle 38 getenv ; +: stderr-handle 61 getenv ; M: object (init-stdio) stdin-handle diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 9540081d5b..9b994b4bbf 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order -combinators ; +combinators generic ; IN: math.intervals TUPLE: interval { from read-only } { to read-only } ; @@ -177,6 +177,11 @@ C: interval : interval/ ( i1 i2 -- i3 ) [ [ / ] interval-op ] interval-division-op ; +: interval/-safe ( i1 i2 -- i3 ) + #! Just a hack to make the compiler work if bootstrap.math + #! is not loaded. + \ integer \ / method [ interval/ ] [ 2drop f ] if ; + : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b7a3ff28e7..27ef4042e2 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -158,7 +158,7 @@ optimizer.math.partial generic.standard system accessors ; { + { { fixnum integer } } interval+ } { - { { fixnum integer } } interval- } { * { { fixnum integer } } interval* } - { / { { fixnum rational } { integer rational } } interval/ } + { / { { fixnum rational } { integer rational } } interval/-safe } { /i { { fixnum integer } } interval/i } { shift { { fixnum integer } } interval-shift-safe } } [ diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 4fe4c5bcb2..552d64cfe7 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -15,7 +15,7 @@ id continuation state runnable mailbox variables sleep-entry ; -: self ( -- thread ) 40 getenv ; inline +: self ( -- thread ) 63 getenv ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -30,7 +30,7 @@ mailbox variables sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads 41 getenv ; +: threads 64 getenv ; : thread ( id -- thread ) threads at ; @@ -53,7 +53,7 @@ mailbox variables sleep-entry ; : unregister-thread ( thread -- ) check-registered id>> threads delete-at ; -: set-self ( thread -- ) 40 setenv ; inline +: set-self ( thread -- ) 63 setenv ; inline PRIVATE> @@ -68,9 +68,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue 42 getenv ; +: run-queue 65 getenv ; -: sleep-queue 43 getenv ; +: sleep-queue 66 getenv ; : resume ( thread -- ) f >>state @@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- ) 42 setenv - 43 setenv + H{ } clone 64 setenv + 65 setenv + 66 setenv initial-thread global [ drop f "Initial" ] cache >>continuation diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 96d7cf9905..3d699a2623 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/bit-arrays/bit-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel -kernel.private sequences sequences.private byte-arrays +kernel.private locals sequences sequences.private byte-arrays parser prettyprint.backend ; IN: bit-arrays @@ -72,14 +72,16 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ ( parsed -- parsed ) \ } [ >bit-array ] parse-literal ; parsing -: integer>bit-array ( int -- bit-array ) - dup zero? [ drop 0 ] [ - [ log2 1+ 0 ] keep - [ dup zero? not ] [ - [ -8 shift ] [ 255 bitand ] bi - -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip - ] [ ] while - 2drop +:: integer>bit-array ( n -- bit-array ) + n zero? [ 0 ] [ + [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | + [ n' zero? not ] [ + n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' -8 shift n'! + i 1+ i! + ] [ ] while + out + ] ] if ; : bit-array>integer ( bit-array -- int ) diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor index a2f0cccf3b..a5b26e3fd0 100644 --- a/extra/columns/columns-docs.factor +++ b/extra/columns/columns-docs.factor @@ -11,7 +11,7 @@ HELP: column HELP: ( seq n -- column ) { $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } -{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } +{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example "USING: arrays prettyprint columns ;" diff --git a/extra/ctags/authors.txt b/extra/ctags/authors.txt new file mode 100644 index 0000000000..158cf94ea0 --- /dev/null +++ b/extra/ctags/authors.txt @@ -0,0 +1 @@ +Alfredo Beaumont diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor new file mode 100644 index 0000000000..9d98cae0b3 --- /dev/null +++ b/extra/ctags/ctags-docs.factor @@ -0,0 +1,60 @@ +USING: help.syntax help.markup kernel prettyprint sequences strings ; +IN: ctags + +ARTICLE: "ctags" "Ctags file" +{ $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "." +{ $subsection ctags } +{ $subsection ctags-write } +{ $subsection ctag-strings } +{ $subsection ctag } ; + +HELP: ctags ( path -- ) +{ $values { "path" "a pathname string" } } +{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." } +{ $examples + { $example + "USING: ctags ;" + "\"tags\" ctags-write" + "" + } +} ; + +HELP: ctags-write ( seq path -- ) +{ $values { "alist" "an association list" } + { "path" "a pathname string" } } +{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } +{ $examples + { $example + "USING: kernel ctags ;" + "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write" + "" + } +} +{ $notes + { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ; + +HELP: ctag-strings ( alist -- seq ) +{ $values { "alist" "an association list" } + { "seq" sequence } } +{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." } +{ $examples + { $example + "USING: kernel ctags ;" + "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings" + "{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }" + } +} ; + +HELP: ctag ( seq -- str ) +{ $values { "seq" sequence } + { "str" string } } +{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" } +{ $examples + { $example + "USING: kernel ctags ;" + "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ." + "\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\"" + } +} ; + +ABOUT: "ctags" \ No newline at end of file diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor new file mode 100644 index 0000000000..6c73b58ecb --- /dev/null +++ b/extra/ctags/ctags-tests.factor @@ -0,0 +1,12 @@ +USING: kernel ctags tools.test io.backend sequences arrays prettyprint ; +IN: ctags.tests + +[ t ] [ + "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append + { if { "resource:extra/unix/unix.factor" 91 } } ctag = +] unit-test + +[ t ] [ + "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array + { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings = +] unit-test \ No newline at end of file diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor new file mode 100644 index 0000000000..c8bf2272fb --- /dev/null +++ b/extra/ctags/ctags.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Alfredo Beaumont +! See http://factorcode.org/license.txt for BSD license. + +! Simple Ctags generator +! Alfredo Beaumont + +USING: arrays kernel sequences io io.files io.backend +io.encodings.ascii math.parser vocabs definitions +namespaces words sorting ; +IN: ctags + +: ctag ( seq -- str ) + [ + dup first ?word-name % + "\t" % + second dup first normalize-path % + "\t" % + second number>string % + ] "" make ; + +: ctag-strings ( seq1 -- seq2 ) + { } swap [ ctag suffix ] each ; + +: ctags-write ( seq path -- ) + >r ctag-strings r> ascii set-file-lines ; + +: (ctags) ( -- seq ) + { } all-words [ + dup where [ + 2array suffix + ] [ + drop + ] if* + ] each ; + +: ctags ( path -- ) + (ctags) sort-keys swap ctags-write ; \ No newline at end of file diff --git a/extra/ctags/summary.txt b/extra/ctags/summary.txt new file mode 100644 index 0000000000..2025e02521 --- /dev/null +++ b/extra/ctags/summary.txt @@ -0,0 +1 @@ +Ctags generator diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 7f154a4dbf..e002af8f6d 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/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 ; +generic.standard sequences.private kernel.private ; IN: tools.walker.tests [ { } ] [ @@ -50,6 +50,10 @@ IN: tools.walker.tests [ 5 6 number= ] test-walker ] unit-test +[ { 0 } ] [ + [ 0 { array-capacity } declare ] test-walker +] unit-test + [ { f } ] [ [ "XYZ" "XYZ" mismatch ] test-walker ] unit-test diff --git a/vm/os-unix.c b/vm/os-unix.c index 5b0da5a8d2..48d9a2dea8 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -322,8 +322,16 @@ void safe_write(int fd, void *data, size_t size) void safe_read(int fd, void *data, size_t size) { - if(read(fd,data,size) != size) - fatal_error("error reading fd",errno); + ssize_t bytes = read(fd,data,size); + if(bytes < 0) + { + if(errno == EINTR) + safe_read(fd,data,size); + else + fatal_error("error reading fd",errno); + } + else if(bytes != size) + fatal_error("unexpected eof on fd",bytes); } void *stdin_loop(void *arg) diff --git a/vm/os-unix.h b/vm/os-unix.h index 6d220de903..6db03148cd 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -27,6 +27,8 @@ typedef char F_SYMBOL; #define OPEN_WRITE(path) fopen(path,"wb") #define FPRINTF(stream,format,arg) fprintf(stream,format,arg) +void start_thread(void *(*start_routine)(void *)); + void init_ffi(void); void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); diff --git a/vm/quotations.c b/vm/quotations.c index e092aab4bf..7eab41688a 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -25,6 +25,13 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } +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]; +} + F_ARRAY *code_to_emit(CELL name) { return untag_object(array_nth(untag_object(userenv[name]),0)); @@ -72,8 +79,24 @@ bool jit_stack_frame_p(F_ARRAY *array) for(i = 0; i < length - 1; i++) { - if(type_of(array_nth(array,i)) == WORD_TYPE) - return true; + CELL obj = array_nth(array,i); + if(type_of(obj) == WORD_TYPE) + { + if(obj != userenv[JIT_TAG_WORD] + && obj != userenv[JIT_EQP_WORD] + && obj != userenv[JIT_SLOT_WORD] + && obj != userenv[JIT_DROP_WORD] + && obj != userenv[JIT_DUP_WORD] + && obj != userenv[JIT_TO_R_WORD] + && obj != userenv[JIT_FROM_R_WORD] + && obj != userenv[JIT_SWAP_WORD] + && obj != userenv[JIT_OVER_WORD] + && obj != userenv[JIT_FIXNUM_MINUS_WORD] + && obj != userenv[JIT_FIXNUM_GE_WORD]) + { + return true; + } + } } return false; @@ -131,24 +154,74 @@ void jit_compile(CELL quot, bool relocate) switch(type_of(obj)) { case WORD_TYPE: - /* Emit the epilog before the primitive call gate - so that we save the C stack pointer minus the - current stack frame. */ - word = untag_object(obj); - - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - - if(i == length - 1) + /* Intrinsics */ + if(obj == userenv[JIT_TAG_WORD]) { - if(stack_frame) - EMIT(JIT_EPILOG,0); - - EMIT(JIT_WORD_JUMP,literals_count - 1); - - tail_call = true; + EMIT(JIT_TAG,0); + } + else if(obj == userenv[JIT_EQP_WORD]) + { + GROWABLE_ARRAY_ADD(literals,T); + EMIT(JIT_EQP,literals_count - 1); + } + else if(obj == userenv[JIT_SLOT_WORD]) + { + EMIT(JIT_SLOT,0); + } + else if(obj == userenv[JIT_DROP_WORD]) + { + EMIT(JIT_DROP,0); + } + else if(obj == userenv[JIT_DUP_WORD]) + { + EMIT(JIT_DUP,0); + } + else if(obj == userenv[JIT_TO_R_WORD]) + { + EMIT(JIT_TO_R,0); + } + else if(obj == userenv[JIT_FROM_R_WORD]) + { + EMIT(JIT_FROM_R,0); + } + else if(obj == userenv[JIT_SWAP_WORD]) + { + EMIT(JIT_SWAP,0); + } + else if(obj == userenv[JIT_OVER_WORD]) + { + EMIT(JIT_OVER,0); + } + else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) + { + EMIT(JIT_FIXNUM_MINUS,0); + } + else if(obj == userenv[JIT_FIXNUM_GE_WORD]) + { + GROWABLE_ARRAY_ADD(literals,T); + EMIT(JIT_FIXNUM_GE,literals_count - 1); } else - EMIT(JIT_WORD_CALL,literals_count - 1); + { + /* Emit the epilog before the primitive call gate + so that we save the C stack pointer minus the + current stack frame. */ + word = untag_object(obj); + + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + + if(i == length - 1) + { + if(stack_frame) + EMIT(JIT_EPILOG,0); + + EMIT(JIT_WORD_JUMP,literals_count - 1); + + tail_call = true; + } + else + EMIT(JIT_WORD_CALL,literals_count - 1); + } break; case WRAPPER_TYPE: wrapper = untag_object(obj); @@ -194,6 +267,11 @@ void jit_compile(CELL quot, bool relocate) tail_call = true; break; } + else if(jit_ignore_declare_p(untag_object(array),i)) + { + i++; + break; + } default: GROWABLE_ARRAY_ADD(literals,obj); EMIT(JIT_PUSH_LITERAL,literals_count - 1); @@ -261,24 +339,47 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) 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(i == length - 1) - { - if(stack_frame) - COUNT(JIT_EPILOG,i); - - COUNT(JIT_WORD_JUMP,i) - - tail_call = true; - } + /* Intrinsics */ + if(obj == userenv[JIT_TAG_WORD]) + COUNT(JIT_TAG,i) + else if(obj == userenv[JIT_EQP_WORD]) + COUNT(JIT_EQP,i) + else if(obj == userenv[JIT_SLOT_WORD]) + COUNT(JIT_SLOT,i) + else if(obj == userenv[JIT_DROP_WORD]) + COUNT(JIT_DROP,i) + else if(obj == userenv[JIT_DUP_WORD]) + COUNT(JIT_DUP,i) + else if(obj == userenv[JIT_TO_R_WORD]) + COUNT(JIT_TO_R,i) + else if(obj == userenv[JIT_FROM_R_WORD]) + COUNT(JIT_FROM_R,i) + else if(obj == userenv[JIT_SWAP_WORD]) + COUNT(JIT_SWAP,i) + else if(obj == userenv[JIT_OVER_WORD]) + COUNT(JIT_OVER,i) + else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) + COUNT(JIT_FIXNUM_MINUS,i) + else if(obj == userenv[JIT_FIXNUM_GE_WORD]) + COUNT(JIT_FIXNUM_GE,i) else - COUNT(JIT_WORD_CALL,i) + { + if(i == length - 1) + { + if(stack_frame) + COUNT(JIT_EPILOG,i); + + COUNT(JIT_WORD_JUMP,i) + + tail_call = true; + } + else + COUNT(JIT_WORD_CALL,i) + } break; case WRAPPER_TYPE: COUNT(JIT_PUSH_LITERAL,i) @@ -319,6 +420,14 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) tail_call = true; break; } + if(jit_ignore_declare_p(untag_object(array),i)) + { + if(offset == 0) return i; + + i++; + + break; + } default: COUNT(JIT_PUSH_LITERAL,i) break; diff --git a/vm/run.h b/vm/run.h index cc980453cf..b54640ec8a 100755 --- a/vm/run.h +++ b/vm/run.h @@ -1,4 +1,4 @@ -#define USER_ENV 64 +#define USER_ENV 70 typedef enum { NAMESTACK_ENV, /* used by library only */ @@ -47,20 +47,43 @@ typedef enum { JIT_EPILOG, JIT_RETURN, JIT_PROFILING, + JIT_TAG, + JIT_TAG_WORD, + JIT_EQP, + JIT_EQP_WORD, + JIT_SLOT, + JIT_SLOT_WORD, + JIT_DECLARE_WORD, + JIT_DROP, + JIT_DROP_WORD, + JIT_DUP, + JIT_DUP_WORD, + JIT_TO_R, + JIT_TO_R_WORD, + JIT_FROM_R, + JIT_FROM_R_WORD, + JIT_SWAP, + JIT_SWAP_WORD, + JIT_OVER, + JIT_OVER_WORD, + JIT_FIXNUM_MINUS, + JIT_FIXNUM_MINUS_WORD, + JIT_FIXNUM_GE, + JIT_FIXNUM_GE_WORD, - STACK_TRACES_ENV = 36, + STACK_TRACES_ENV = 59, - UNDEFINED_ENV = 37, /* default quotation for undefined words */ + UNDEFINED_ENV = 60, /* default quotation for undefined words */ - STDERR_ENV = 38, /* stderr FILE* handle */ + STDERR_ENV = 61, /* stderr FILE* handle */ - STAGE2_ENV = 39, /* have we bootstrapped? */ + STAGE2_ENV = 62, /* have we bootstrapped? */ - CURRENT_THREAD_ENV = 40, + CURRENT_THREAD_ENV = 63, - THREADS_ENV = 41, - RUN_QUEUE_ENV = 42, - SLEEP_QUEUE_ENV = 43, + THREADS_ENV = 64, + RUN_QUEUE_ENV = 65, + SLEEP_QUEUE_ENV = 66, } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV