Merge branch 'master' of git://factorcode.org/git/factor

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 <alien> ] curry
+    alien-callback-xt [ word-xt drop <alien> ] curry
     recursive-state get infer-quot ;
 
 \ alien-callback [

core/alien/structs/structs-tests.factor

@@ -9,18 +9,20 @@ C-STRUCT: bar
 [ 36 ] [ "bar" heap-size ] unit-test
 [ t ] [ \ <displaced-alien> "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 ;
 

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

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

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 -- )

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

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 } } }

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? ;

core/inference/known-words/known-words.factor

@@ -345,7 +345,7 @@ M: object infer-call
 \ <word> { object object } { word } <effect> set-primitive-effect
 \ <word> make-flushable
 
-\ word-xt { word } { integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } <effect> set-primitive-effect
 \ word-xt make-flushable
 
 \ getenv { fixnum } { object } <effect> set-primitive-effect

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

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 ;
 

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

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>
 

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 } } }

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

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

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 ;

extra/tools/disassembler/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Jorge Acereda Macia

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 ;

extra/tools/disassembler/summary.txt

@@ -0,0 +1 @@
+Disassemble words using gdb

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

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 ;

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)