diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 282a849c34..f68bdcf0a2 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -326,7 +326,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt ] curry + alien-callback-xt [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b2da0e8392..b934cd56a3 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -9,18 +9,20 @@ C-STRUCT: bar [ 36 ] [ "bar" heap-size ] unit-test [ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test -C-STRUCT: align-test - { "int" "x" } - { "double" "y" } ; +! This was actually only correct on Windows/x86: -[ 16 ] [ "align-test" heap-size ] unit-test - -cell 4 = [ - C-STRUCT: one - { "long" "a" } { "double" "b" } { "int" "c" } ; - - [ 24 ] [ "one" heap-size ] unit-test -] when +! C-STRUCT: align-test +! { "int" "x" } +! { "double" "y" } ; +! +! [ 16 ] [ "align-test" heap-size ] unit-test +! +! cell 4 = [ +! C-STRUCT: one +! { "long" "a" } { "double" "b" } { "int" "c" } ; +! +! [ 24 ] [ "one" heap-size ] unit-test +! ] when : MAX_FOOS 30 ; diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 1ed43120d3..6deed6c756 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ; [ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test + +! Regression +[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 74e5ab80a4..4be700f221 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts -words definitions compiler.units ; +words definitions compiler.units io combinators ; IN: temporary ! Oops! @@ -191,3 +191,18 @@ TUPLE: my-tuple ; 2 1 [ 2dup fixnum< [ >r die r> ] when ] compile-call ] unit-test + +! Regression +: a-dummy drop "hi" print ; + +[ ] [ + 1 [ + dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [ + drop - >fixnum { + [ a-dummy ] + [ a-dummy ] + [ a-dummy ] + } dispatch + ] [ 2drop no-case ] if + ] compile-call +] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 8b6742e700..e6a6226afa 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -158,17 +158,10 @@ M: #if generate-node ] with-generator ] keep ; -: tail-dispatch? ( node -- ? ) - #! Is the dispatch a jump to a tail call to a word? - dup #call? swap node-successor #return? and ; - : dispatch-branches ( node -- ) node-children [ - dup tail-dispatch? [ - node-param - ] [ - compiling-word get dispatch-branch - ] if %dispatch-label + compiling-word get dispatch-branch + %dispatch-label ] each ; : generate-dispatch ( node -- ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 2cc28ac0d1..0b2b9fcca3 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ; 2drop object-method ] if ; -: math-vtable* ( picker max quot -- quot ) +: math-vtable ( picker quot -- quot ) [ - rot , \ tag , - [ >r [ bootstrap-type>class ] map r> map % ] { } make , + >r + , \ tag , + num-tags get [ bootstrap-type>class ] + r> compose map , \ dispatch , ] [ ] make ; inline -: math-vtable ( picker quot -- quot ) - num-tags get swap math-vtable* ; inline - TUPLE: math-combination ; M: math-combination make-default-method diff --git a/core/inference/dataflow/dataflow-docs.factor b/core/inference/dataflow/dataflow-docs.factor index 0f809fa2bd..66b3590253 100755 --- a/core/inference/dataflow/dataflow-docs.factor +++ b/core/inference/dataflow/dataflow-docs.factor @@ -1,4 +1,5 @@ -USING: inference.dataflow help.syntax help.markup ; +USING: help.syntax help.markup ; +IN: inference.dataflow HELP: #return { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 9bca648b08..23b5343c9c 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -317,4 +317,8 @@ UNION: #tail POSTPONE: f #return #tail-values #tail-merge #terminate ; : tail-call? ( -- ? ) - node-stack get [ node-successor #tail? ] all? ; + #! We don't consider calls which do non-local exits to be + #! tail calls, because this gives better error traces. + node-stack get [ + node-successor dup #tail? swap #terminate? not and + ] all? ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index e6479d0c6a..9d0f959b68 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -345,7 +345,7 @@ M: object infer-call \ { object object } { word } set-primitive-effect \ make-flushable -\ word-xt { word } { integer } set-primitive-effect +\ word-xt { word } { integer integer } set-primitive-effect \ word-xt make-flushable \ getenv { fixnum } { object } set-primitive-effect diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index 2d52e6f45a..ab5c055fbd 100644 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -1,6 +1,7 @@ IN: temporary USING: tools.test optimizer.control combinators kernel -sequences inference.dataflow math inference ; +sequences inference.dataflow math inference classes strings +optimizer ; : label-is-loop? ( node word -- ? ) [ @@ -60,3 +61,88 @@ sequences inference.dataflow math inference ; [ loop-test-3 ] dataflow dup detect-loops \ loop-test-3 label-is-not-loop? ] unit-test + +: loop-test-4 ( a -- ) + dup [ + loop-test-4 + ] [ + drop + ] if ; inline + +: find-label ( node -- label ) + dup #label? [ node-successor find-label ] unless ; + +: test-loop-exits + dataflow dup detect-loops find-label + dup node-param swap + [ node-child find-tail find-loop-exits [ class ] map ] keep + #label-loop? ; + +[ { #values } t ] [ + [ loop-test-4 ] test-loop-exits +] unit-test + +: loop-test-5 ( a -- ) + dup [ + dup string? [ + loop-test-5 + ] [ + drop + ] if + ] [ + drop + ] if ; inline + +[ { #values #values } t ] [ + [ loop-test-5 ] test-loop-exits +] unit-test + +: loop-test-6 ( a -- ) + dup [ + dup string? [ + loop-test-6 + ] [ + 3 throw + ] if + ] [ + drop + ] if ; inline + +[ { #values } t ] [ + [ loop-test-6 ] test-loop-exits +] unit-test + +[ f ] [ + [ [ [ ] map ] map ] dataflow optimize + [ dup #label? swap #loop? not and ] node-exists? +] unit-test + +: blah f ; + +DEFER: a + +: b ( -- ) + blah [ b ] [ a ] if ; inline + +: a ( -- ) + blah [ b ] [ a ] if ; inline + +[ t ] [ + [ a ] dataflow dup detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] dataflow dup detect-loops + \ b label-is-loop? +] unit-test + +[ t ] [ + [ b ] dataflow dup detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] dataflow dup detect-loops + \ b label-is-loop? +] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index de3aeb220a..c9b3458d2a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -68,7 +68,7 @@ M: #label detect-loops* t swap set-#label-loop? ; node-stack get dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail [ node-successor #tail? ] all? ; - +USE: io : detect-loop ( seen-other? label node -- seen-other? continue? ) #! seen-other?: have we seen another label? { @@ -135,15 +135,6 @@ M: #call-label detect-loops* r> [ set-node-successor ] keep ; ! ! ! Lifting code after a conditional if one branch throws -: only-one ( seq -- elt/f ) - dup length 1 = [ first ] [ drop f ] if ; - -: lift-throw-tail? ( #if -- tail/? ) - dup node-successor #tail? - [ drop f ] [ active-children only-one ] if ; - -: clone-node ( node -- newnode ) - clone dup [ clone ] modify-values ; ! BEFORE ! @@ -177,7 +168,17 @@ M: #call-label detect-loops* ! the same node as (***) ! ! Note: if (**) is #return is is sound to put #terminate there, -! but not if (**) is #values +! but not if (**) is # + +: only-one ( seq -- elt/f ) + dup length 1 = [ first ] [ drop f ] if ; + +: lift-throw-tail? ( #if -- tail/? ) + dup node-successor #tail? + [ drop f ] [ active-children only-one ] if ; + +: clone-node ( node -- newnode ) + clone dup [ clone ] modify-values ; : lift-branch over @@ -196,20 +197,6 @@ M: #if optimize-node* ] if ] if ; -: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; - -: fold-dispatch-branch ( node value -- node' ) - dupd node-literal - over drop-inputs >r fold-branch r> - [ set-node-successor ] keep ; - -M: #dispatch optimize-node* - dup fold-dispatch-branch? [ - fold-dispatch-branch t - ] [ - 2drop t f - ] if ; - ! Loop tail hoising: code after a loop can sometimes go in the ! non-recursive branch of the loop @@ -247,6 +234,33 @@ M: #dispatch optimize-node* ! | ! #return 1 +: find-tail ( node -- tail ) + dup #terminate? [ + dup node-successor #tail? [ + node-successor find-tail + ] unless + ] unless ; + +: child-tails ( node -- seq ) + node-children [ find-tail ] map ; + +GENERIC: add-loop-exit* ( label node -- ) + +M: #branch add-loop-exit* + child-tails [ add-loop-exit* ] with each ; + +M: #call-label add-loop-exit* + tuck node-param eq? [ drop ] [ node-successor , ] if ; + +M: #terminate add-loop-exit* + 2drop ; + +M: node add-loop-exit* + nip node-successor dup #terminate? [ drop ] [ , ] if ; + +: find-loop-exits ( label node -- seq ) + [ add-loop-exit* ] { } make ; + : find-final-if ( node -- #if/f ) dup [ dup #if? [ @@ -264,11 +278,7 @@ M: #dispatch optimize-node* : lift-loop-tail? ( #label -- tail/f ) dup node-successor node-successor [ dup node-param swap node-child find-final-if dup [ - node-children [ penultimate-node ] map - [ - dup #call-label? - [ node-param eq? not ] [ 2drop t ] if - ] with subset only-one + find-loop-exits only-one ] [ 2drop f ] if ] [ drop f ] if ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6a76892246..7092797acc 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining ; +continuations growable optimizer.inlining namespaces ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -329,3 +329,25 @@ TUPLE: silly-tuple a b ; 10 [ ] lift-loop-tail-test-1 1 2 3 ; [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 967fcbbdc8..ee38d30750 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence : check-copy ( src n dst -- ) over 0 < [ bounds-error ] when - >r swap length + r> lengthen ; + >r swap length + r> lengthen ; inline PRIVATE> diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor old mode 100644 new mode 100755 index 181979bfed..ece90d9a11 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -9,6 +9,7 @@ $nl { $subsection in-thread } { $subsection yield } { $subsection sleep } +"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:" { $subsection stop } "Continuations can be added to the run queue directly:" { $subsection schedule-thread } @@ -21,7 +22,8 @@ ABOUT: "threads" HELP: run-queue { $values { "queue" dlist } } -{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; +{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } +" and dequeued with " { $link pop-back } "." } ; HELP: schedule-thread { $values { "continuation" "a continuation reified by " { $link callcc0 } } } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 62848e46b2..91b5295427 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -245,8 +245,8 @@ HELP: remove-word-prop { $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." } { $side-effects "word" } ; -HELP: word-xt -{ $values { "word" word } { "xt" "an execution token integer" } } +HELP: word-xt ( word -- start end ) +{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } } { $description "Outputs the machine code address of the word's definition." } ; HELP: define-symbol diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index ebf14417c0..db65a678cf 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -82,7 +82,10 @@ M: #call node>quot #call>quot ; M: #call-label node>quot #call>quot ; M: #label node>quot - [ "#label: " over node-param word-name append comment, ] 2keep + [ + dup #label-loop? "#loop: " "#label: " ? + over node-param word-name append comment, + ] 2keep node-child swap dataflow>quot , \ call , ; M: #if node>quot diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1beec90b75..4c0ea04f24 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -205,3 +205,6 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: replace ( seq old new -- newseq ) + [ pick pick = [ 2nip ] [ 2drop ] if ] 2curry map ; diff --git a/extra/tools/disassembler/authors.txt b/extra/tools/disassembler/authors.txt new file mode 100644 index 0000000000..ef44eb9634 --- /dev/null +++ b/extra/tools/disassembler/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Jorge Acereda Macia diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor new file mode 100644 index 0000000000..641eae90c2 --- /dev/null +++ b/extra/tools/disassembler/disassembler.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files io words alien kernel math.parser alien.syntax +io.launcher system assocs arrays sequences namespaces qualified +regexp system math sequences.lib ; +QUALIFIED: unix +IN: tools.disassembler + +: in-file "gdb-in.txt" resource-path ; + +: out-file "gdb-out.txt" resource-path ; + +GENERIC: make-disassemble-cmd ( obj -- ) + +M: word make-disassemble-cmd + word-xt cell - 2array make-disassemble-cmd ; + +M: pair make-disassemble-cmd + in-file [ + "attach " write + unix:getpid number>string print + + "disassemble " write + [ number>string write bl ] each + ] with-file-out ; + +: run-gdb ( -- lines ) + [ + +closed+ +stdin+ set + out-file +stdout+ set + [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set + ] { } make-assoc run-process drop + out-file file-lines ; + +: relevant? ( line -- ? ) + R/ 0x.*:.*/ matches? ; + +: tabs>spaces ( str -- str' ) + CHAR: \t CHAR: \s replace ; + +: disassemble ( word -- ) + make-disassemble-cmd run-gdb + [ relevant? ] subset [ tabs>spaces ] map [ print ] each ; diff --git a/extra/tools/disassembler/summary.txt b/extra/tools/disassembler/summary.txt new file mode 100644 index 0000000000..f1a689c877 --- /dev/null +++ b/extra/tools/disassembler/summary.txt @@ -0,0 +1 @@ +Disassemble words using gdb diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 3af3d927d7..419d3bcefd 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,7 @@ -USING: assocs math kernel sequences io.files hashtables -quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units parser ; +USING: assocs math kernel sequences sequences.lib io.files +hashtables quotations splitting arrays math.parser +combinators.lib hash2 byte-arrays words namespaces words +compiler.units parser ; IN: unicode.data << @@ -93,9 +94,6 @@ IN: unicode.data : ascii-lower ( string -- lower ) [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; -: replace ( seq old new -- newseq ) - swap rot [ 2dup = [ drop over ] when ] map 2nip ; - : process-names ( data -- names-hash ) 1 swap (process-data) [ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 59141c1940..9d5a6122a2 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -125,6 +125,7 @@ FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; FUNCTION: char* getcwd ( char* buf, size_t size ) ; +FUNCTION: pid_t getpid ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/vm/types.c b/vm/types.c index 78e74535b8..fb61213385 100755 --- a/vm/types.c +++ b/vm/types.c @@ -70,11 +70,13 @@ DEFINE_PRIMITIVE(word) dpush(tag_object(allot_word(vocab,name))); } -/* word-xt ( word -- xt ) */ +/* word-xt ( word -- start end ) */ DEFINE_PRIMITIVE(word_xt) { - F_WORD *word = untag_word(dpeek()); - drepl(allot_cell((CELL)word->xt)); + F_WORD *word = untag_word(dpop()); + F_COMPILED *code = word->code; + dpush(allot_cell((CELL)code + sizeof(F_COMPILED))); + dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length)); } DEFINE_PRIMITIVE(wrapper)