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

db4
Doug Coleman 2008-02-14 22:31:25 -06:00
commit e2a34ed276
23 changed files with 267 additions and 77 deletions

View File

@ -326,7 +326,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- ) : callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry alien-callback-xt [ word-xt drop <alien> ] curry
recursive-state get infer-quot ; recursive-state get infer-quot ;
\ alien-callback [ \ alien-callback [

View File

@ -9,18 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test [ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
C-STRUCT: align-test ! This was actually only correct on Windows/x86:
{ "int" "x" }
{ "double" "y" } ;
[ 16 ] [ "align-test" heap-size ] unit-test ! C-STRUCT: align-test
! { "int" "x" }
cell 4 = [ ! { "double" "y" } ;
C-STRUCT: one !
{ "long" "a" } { "double" "b" } { "int" "c" } ; ! [ 16 ] [ "align-test" heap-size ] unit-test
!
[ 24 ] [ "one" heap-size ] unit-test ! cell 4 = [
] when ! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: MAX_FOOS 30 ; : MAX_FOOS 30 ;

View File

@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test

View File

@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ; words definitions compiler.units io combinators ;
IN: temporary IN: temporary
! Oops! ! Oops!
@ -191,3 +191,18 @@ TUPLE: my-tuple ;
2 1 2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call [ 2dup fixnum< [ >r die r> ] when ] compile-call
] unit-test ] 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

View File

@ -158,17 +158,10 @@ M: #if generate-node
] with-generator ] with-generator
] keep ; ] 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 -- ) : dispatch-branches ( node -- )
node-children [ node-children [
dup tail-dispatch? [ compiling-word get dispatch-branch
node-param %dispatch-label
] [
compiling-word get dispatch-branch
] if %dispatch-label
] each ; ] each ;
: generate-dispatch ( node -- ) : generate-dispatch ( node -- )

View File

@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ;
2drop object-method 2drop object-method
] if ; ] if ;
: math-vtable* ( picker max quot -- quot ) : math-vtable ( picker quot -- quot )
[ [
rot , \ tag , >r
[ >r [ bootstrap-type>class ] map r> map % ] { } make , , \ tag ,
num-tags get [ bootstrap-type>class ]
r> compose map ,
\ dispatch , \ dispatch ,
] [ ] make ; inline ] [ ] make ; inline
: math-vtable ( picker quot -- quot )
num-tags get swap math-vtable* ; inline
TUPLE: math-combination ; TUPLE: math-combination ;
M: math-combination make-default-method M: math-combination make-default-method

View File

@ -1,4 +1,5 @@
USING: inference.dataflow help.syntax help.markup ; USING: help.syntax help.markup ;
IN: inference.dataflow
HELP: #return HELP: #return
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

View File

@ -317,4 +317,8 @@ UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ; POSTPONE: f #return #tail-values #tail-merge #terminate ;
: tail-call? ( -- ? ) : 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? ;

View File

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

View File

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: tools.test optimizer.control combinators kernel 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 -- ? ) : label-is-loop? ( node word -- ? )
[ [
@ -60,3 +61,88 @@ sequences inference.dataflow math inference ;
[ loop-test-3 ] dataflow dup detect-loops [ loop-test-3 ] dataflow dup detect-loops
\ loop-test-3 label-is-not-loop? \ loop-test-3 label-is-not-loop?
] unit-test ] 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

View File

@ -68,7 +68,7 @@ M: #label detect-loops* t swap set-#label-loop? ;
node-stack get node-stack get
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
[ node-successor #tail? ] all? ; [ node-successor #tail? ] all? ;
USE: io
: detect-loop ( seen-other? label node -- seen-other? continue? ) : detect-loop ( seen-other? label node -- seen-other? continue? )
#! seen-other?: have we seen another label? #! seen-other?: have we seen another label?
{ {
@ -135,15 +135,6 @@ M: #call-label detect-loops*
r> [ set-node-successor ] keep ; r> [ set-node-successor ] keep ;
! ! ! Lifting code after a conditional if one branch throws ! ! ! 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 ! BEFORE
! !
@ -177,7 +168,17 @@ M: #call-label detect-loops*
! the same node as (***) ! the same node as (***)
! !
! Note: if (**) is #return is is sound to put #terminate there, ! 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 : lift-branch
over over
@ -196,20 +197,6 @@ M: #if optimize-node*
] if ] if
] 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 ! Loop tail hoising: code after a loop can sometimes go in the
! non-recursive branch of the loop ! non-recursive branch of the loop
@ -247,6 +234,33 @@ M: #dispatch optimize-node*
! | ! |
! #return 1 ! #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 ) : find-final-if ( node -- #if/f )
dup [ dup [
dup #if? [ dup #if? [
@ -264,11 +278,7 @@ M: #dispatch optimize-node*
: lift-loop-tail? ( #label -- tail/f ) : lift-loop-tail? ( #label -- tail/f )
dup node-successor node-successor [ dup node-successor node-successor [
dup node-param swap node-child find-final-if dup [ dup node-param swap node-child find-final-if dup [
node-children [ penultimate-node ] map find-loop-exits only-one
[
dup #call-label?
[ node-param eq? not ] [ 2drop t ] if
] with subset only-one
] [ 2drop f ] if ] [ 2drop f ] if
] [ drop f ] if ; ] [ drop f ] if ;

View File

@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining ; continuations growable optimizer.inlining namespaces ;
IN: temporary IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ 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 ; 10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test [ 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

View File

@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence
: check-copy ( src n dst -- ) : check-copy ( src n dst -- )
over 0 < [ bounds-error ] when over 0 < [ bounds-error ] when
>r swap length + r> lengthen ; >r swap length + r> lengthen ; inline
PRIVATE> PRIVATE>

4
core/threads/threads-docs.factor Normal file → Executable file
View File

@ -9,6 +9,7 @@ $nl
{ $subsection in-thread } { $subsection in-thread }
{ $subsection yield } { $subsection yield }
{ $subsection sleep } { $subsection sleep }
"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:"
{ $subsection stop } { $subsection stop }
"Continuations can be added to the run queue directly:" "Continuations can be added to the run queue directly:"
{ $subsection schedule-thread } { $subsection schedule-thread }
@ -21,7 +22,8 @@ ABOUT: "threads"
HELP: run-queue HELP: run-queue
{ $values { "queue" dlist } } { $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 HELP: schedule-thread
{ $values { "continuation" "a continuation reified by " { $link callcc0 } } } { $values { "continuation" "a continuation reified by " { $link callcc0 } } }

View File

@ -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." } { $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" } ; { $side-effects "word" } ;
HELP: word-xt HELP: word-xt ( word -- start end )
{ $values { "word" word } { "xt" "an execution token integer" } } { $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." } ; { $description "Outputs the machine code address of the word's definition." } ;
HELP: define-symbol HELP: define-symbol

View File

@ -82,7 +82,10 @@ M: #call node>quot #call>quot ;
M: #call-label node>quot #call>quot ; M: #call-label node>quot #call>quot ;
M: #label node>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 , ; node-child swap dataflow>quot , \ call , ;
M: #if node>quot M: #if node>quot

View File

@ -205,3 +205,6 @@ PRIVATE>
: attempt-each ( seq quot -- result ) : attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline (each) iterate-prep (attempt-each-integer) ; inline
: replace ( seq old new -- newseq )
[ pick pick = [ 2nip ] [ 2drop ] if ] 2curry map ;

View File

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

View File

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

View File

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

View File

@ -1,6 +1,7 @@
USING: assocs math kernel sequences io.files hashtables USING: assocs math kernel sequences sequences.lib io.files
quotations splitting arrays math.parser combinators.lib hash2 hashtables quotations splitting arrays math.parser
byte-arrays words namespaces words compiler.units parser ; combinators.lib hash2 byte-arrays words namespaces words
compiler.units parser ;
IN: unicode.data IN: unicode.data
<< <<
@ -93,9 +94,6 @@ IN: unicode.data
: ascii-lower ( string -- lower ) : ascii-lower ( string -- lower )
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; [ 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 ) : process-names ( data -- names-hash )
1 swap (process-data) 1 swap (process-data)
[ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map [ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map

View File

@ -125,6 +125,7 @@ FUNCTION: int futimes ( int id, timeval[2] times ) ;
FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: char* gai_strerror ( int ecode ) ;
FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: char* getcwd ( char* buf, size_t size ) ;
FUNCTION: pid_t getpid ;
FUNCTION: int getdtablesize ; FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ; FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ; FUNCTION: uid_t geteuid ;

View File

@ -70,11 +70,13 @@ DEFINE_PRIMITIVE(word)
dpush(tag_object(allot_word(vocab,name))); dpush(tag_object(allot_word(vocab,name)));
} }
/* word-xt ( word -- xt ) */ /* word-xt ( word -- start end ) */
DEFINE_PRIMITIVE(word_xt) DEFINE_PRIMITIVE(word_xt)
{ {
F_WORD *word = untag_word(dpeek()); F_WORD *word = untag_word(dpop());
drepl(allot_cell((CELL)word->xt)); 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) DEFINE_PRIMITIVE(wrapper)