Merge branch 'master' of git://factorcode.org/git/factor
commit
e2a34ed276
|
@ -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 [
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 } } }
|
||||||
|
|
|
@ -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? ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
|
@ -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 } } }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -0,0 +1,2 @@
|
||||||
|
Slava Pestov
|
||||||
|
Jorge Acereda Macia
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
||||||
|
Disassemble words using gdb
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue