steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-16 18:50:45 -06:00
parent 58caa17155 d51b351adf
commit b2e0c3d636
22 changed files with 184 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
core/generic/generic.factor
View File

@ -82,10 +82,19 @@ M: method-body stack-effect
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: redefine-method ( quot method -- )
2dup set-method-def
method-word swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
[ <method> ] 2keep
[ set-at ] with-methods ;
2dup method dup [
2nip redefine-method
] [
drop
[ <method> ] 2keep
[ set-at ] with-methods
] if ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>

5
core/inference/class/class-tests.factor
View File

@ -283,3 +283,8 @@ cell-bits 32 = [
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
\ number= inlined?
] unit-test
[ t ] [
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test

118
core/optimizer/inlining/inlining.factor
View File

@ -6,62 +6,38 @@ math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control ;
optimizer.control kernel.private ;
IN: optimizer.inlining
GENERIC: remember-method* ( method-spec node -- )
: remember-inlining ( node history -- )
[ swap set-node-history ] curry each-node ;
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
: inlining-quot ( node quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
dup rot infer-classes/node ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
: splice-quot ( #call quot history -- node )
#! Must add history *before* splicing in, otherwise
#! the rest of the IR will also remember the history
pick node-history append
>r dupd inlining-quot dup r> remember-inlining
tuck splice-node ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
{
! heuristic: { ... } declare comes up in method bodies
! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] }
! recursive
{ [ dup get ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
{ [ t ] [ dup dup set word-def (flat-length) ] }
} cond ;
: (flat-length) ( seq -- n )
[
@ -76,32 +52,29 @@ DEFER: (flat-length)
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
2dup dispatching-class dup [
swap method method-word 1quotation f splice-quot
] [
3drop t
] if ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
over node-input-classes first2 3dup math-both-known?
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
@ -131,7 +104,7 @@ DEFER: (flat-length)
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
dupd literal-quot f splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
@ -196,7 +169,7 @@ DEFER: (flat-length)
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
@ -206,13 +179,20 @@ DEFER: (flat-length)
2drop f
] if ;
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
dup word-def swap 1array splice-quot ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
dup node-param over node-history memq? [
drop t
] [
dup node-param splice-word-def
] if ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
[ flat-length 10 <= ] [ drop f ] if ;
M: #call optimize-node*
{

4
core/optimizer/known-words/known-words.factor
View File

@ -40,7 +40,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
: flip-branches ( #call -- #if )
#! If a not is followed by an #if, flip branches and
#! remove the not.
dup sole-consumer (flip-branches) [ ] splice-quot ;
dup sole-consumer (flip-branches) [ ] f splice-quot ;
\ not {
{ [ dup flip-branches? ] [ flip-branches ] }
@ -63,7 +63,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot splice-quot ;
dup node-in-d peek value-literal member-quot f splice-quot ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }

6
core/optimizer/math/math.factor
View File

@ -366,7 +366,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
} [
[
[ dup remove-overflow-check? ] ,
[ splice-quot ] curry ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
@ -436,7 +436,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
dup remove-overflow-check?
over coereced-to-fixnum? or
] ,
[ splice-quot ] curry ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
@ -461,6 +461,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ fixnum-shift {
{
[ dup fixnum-shift-fast? ]
[ [ fixnum-shift-fast ] splice-quot ]
[ [ fixnum-shift-fast ] f splice-quot ]
}
} define-optimizers

27
core/optimizer/optimizer-tests.factor
View File

@ -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 namespaces ;
continuations growable optimizer.inlining namespaces hints ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -351,3 +351,28 @@ M: integer generic-inline-test ;
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
] unit-test
! Forgot a recursive inline check
: recursive-inline-hang ( a -- a )
dup array? [ recursive-inline-hang ] when ;
HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
DEFER: recursive-inline-hang-3
: recursive-inline-hang-2 ( a -- a )
dup array? [ recursive-inline-hang-3 ] when ;
HINTS: recursive-inline-hang-2 array ;
: recursive-inline-hang-3 ( a -- a )
dup array? [ recursive-inline-hang-2 ] when ;
HINTS: recursive-inline-hang-3 array ;

2
extra/benchmark/nsieve/nsieve.factor
View File

@ -6,7 +6,7 @@ arrays namespaces io ;
2dup length >= [
3drop
] [
f pick pick set-nth-unsafe >r over + r> clear-flags
f 2over set-nth-unsafe >r over + r> clear-flags
] if ; inline
: (nsieve) ( count i seq -- count )

2
extra/benchmark/recursive/recursive.factor
View File

@ -16,7 +16,7 @@ USING: math kernel hints prettyprint io ;
] if ;
: tak ( x y z -- t )
pick pick swap < [
2over swap < [
[ rot 1- -rot tak ] 3keep
[ -rot 1- -rot tak ] 3keep
1- -rot tak

5
extra/benchmark/sockets/sockets.factor
View File

@ -23,10 +23,9 @@ IN: benchmark.sockets
] with-stream ;
: clients ( n -- )
dup pprint " clients: " write
[
dup pprint " clients: " write [
[ simple-server ] in-thread
100 sleep
yield yield
[ drop simple-client ] parallel-each
stop-server
yield yield

2
extra/channels/examples/examples.factor Normal file → Executable file
View File

@ -24,7 +24,7 @@ IN: channels.examples
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
:: (sieve) | prime c |
:: (sieve) | prime c | ( prime c -- )
[let | p [ c from ]
newc [ <channel> ] |
p prime to

6
extra/concurrency/concurrency.factor
View File

@ -145,12 +145,12 @@ M: process send ( message process -- )
: receive ( -- message )
self process-mailbox mailbox-get dup linked-exception? [
linked-exception-error throw
linked-exception-error rethrow
] when ;
: receive-if ( pred -- message )
self process-mailbox mailbox-get? dup linked-exception? [
linked-exception-error throw
linked-exception-error rethrow
] when ; inline
: rethrow-linked ( error -- )
@ -285,7 +285,7 @@ TUPLE: future value processes ;
#! place the result on the stack. Return the result
#! immediately if the future has completed.
dup future-value [
first2 [ throw ] unless
first2 [ rethrow ] unless
] [
dup [ future-processes push stop ] curry callcc0 ?future
] ?if ;

29
extra/cpu/8080/8080.factor Normal file → Executable file
View File

@ -249,32 +249,3 @@ INSTRUCTION: EI ; opcode FB cycles 04
INSTRUCTION: CALL M,nn ; opcode FC cycles 11
INSTRUCTION: CP n ; opcode FE cycles 07
INSTRUCTION: RST 38H ; opcode FF cycles 11
! : each-8bit ( n quot -- )
! 8 [ ! n quot bit
! pick over -1 * shift 1 bitand pick call
! ] repeat 2drop ;
!
! : >ppm ( cpu filename -- cpu )
! #! Dump the current screen image to a ppm image file with the given name.
! <file-writer> [
! "P3" print
! "256 224" print
! "1" print
! 224 [
! 32 [
! over 32 * over + HEX: 2400 + ! cpu h w addr
! >r pick r> swap cpu-ram nth [
! 0 = [
! " 0 0 0" write
! ] [
! " 1 1 1" write
! ] if
! ] each-8bit
! ] repeat nl
! ] repeat
! ] with-stream ;
: time-test ( -- )
test-cpu [ 1000000 run-n ] time ;

75
extra/cpu/8080/emulator/emulator.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel math sequences words arrays io
io.files namespaces math.parser kernel.private
assocs quotations parser parser-combinators tools.time
sequences.private compiler.units ;
USING: kernel math sequences words arrays io io.files namespaces
math.parser assocs quotations parser parser-combinators
tools.time ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@ -396,39 +395,18 @@ M: cpu write-port ( value port cpu -- )
: instruction-cycles ( -- vector )
#! Return a 256 element vector containing the cycles for
#! each opcode in the 8080 instruction set.
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
: instructions ( -- vector )
#! Return a 256 element vector containing the emulation words for
#! each opcode in the 8080 instruction set.
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
<< 256 f <array> parsed >> ;
: not-implemented ( <cpu> -- )
drop ;
instructions length [
dup instructions nth [
drop
] [
[ not-implemented ] swap instructions set-nth
] if
] each
: instructions ( -- vector )
#! Return a 256 element vector containing the emulation words for
#! each opcode in the 8080 instruction set.
<< 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
: set-instruction ( quot n -- )
tuck >r 2array r> instructions set-nth ;
M: cpu reset ( cpu -- )
#! Reset the CPU to its poweron state
@ -517,15 +495,6 @@ SYMBOL: rom-root
] if
] if ;
: step ( cpu -- )
#! Run a single 8080 instruction
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions dispatch ] keep
[ cpu-pc HEX: FFFF bitand ] keep
[ set-cpu-pc ] keep
process-interrupts ;
: peek-instruction ( cpu -- word )
#! Return the next instruction from the cpu's program
#! counter, but don't increment the counter.
@ -560,18 +529,6 @@ SYMBOL: rom-root
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
nl drop ;
: test-step ( cpu -- cpu )
[ step ] keep dup cpu. ;
: test-cpu ( -- cpu )
<cpu> "invaders.rom" over load-rom dup cpu. ;
: test-n ( n -- )
test-cpu swap [ test-step ] times ;
: run-n ( cpu n -- cpu )
[ dup step ] times ;
: register-lookup ( string -- vector )
#! Given a string containing a register name, return a vector
#! where the 1st item is the getter and the 2nd is the setter
@ -1337,11 +1294,9 @@ SYMBOL: last-opcode
#! Process the list of strings, which should make
#! up an 8080 instruction, and output a quotation
#! that would implement that instruction.
[
dup " " join instruction-quotations
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
r> define
] with-compilation-unit ;
dup " " join instruction-quotations
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
r> define ;
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
@ -1352,5 +1307,5 @@ SYMBOL: last-opcode
: opcode ( -- )
#! Set the opcode number for the last instruction that was defined.
last-instruction global at 1quotation scan 16 base>
dup last-opcode global set-at instructions set-nth ; parsing
dup last-opcode global set-at set-instruction ; parsing

51
extra/cpu/8080/test/test.factor Executable file
View File

@ -0,0 +1,51 @@
USING: kernel cpu.8080 cpu.8080.emulator math math io
tools.time combinators sequences io.files ;
IN: cpu.8080.test
: step ( cpu -- )
#! Run a single 8080 instruction
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions case ] keep
[ cpu-pc HEX: FFFF bitand ] keep
[ set-cpu-pc ] keep
process-interrupts ;
: test-step ( cpu -- cpu )
[ step ] keep dup cpu. ;
: test-cpu ( -- cpu )
<cpu> "invaders.rom" over load-rom dup cpu. ;
: test-n ( n -- )
test-cpu swap [ test-step ] times drop ;
: run-n ( cpu n -- cpu )
[ dup step ] times ;
: each-8bit ( n quot -- )
8 -rot [ >r bit? r> call ] 2curry each ; inline
: >ppm ( cpu filename -- cpu )
#! Dump the current screen image to a ppm image file with the given name.
<file-writer> [
"P3" print
"256 224" print
"1" print
224 [
32 [
over 32 * over + HEX: 2400 + ! cpu h w addr
>r pick r> swap cpu-ram nth [
0 = [
" 0 0 0" write
] [
" 1 1 1" write
] if
] each-8bit drop
] each drop nl
] each
] with-stream ;
: time-test ( -- )
test-cpu [ 1000000 run-n drop ] time ;

6
extra/db/mysql/mysql.factor
View File

@ -26,12 +26,6 @@ M: mysql-statement prepare-statement ( statement -- )
M: mysql-statement bind-statement* ( statement -- )
;
M: mysql-statement rebind-statement ( statement -- )
;
M: mysql-statement execute-statement ( statement -- )
;
M: mysql-statement query-results ( query -- result-set )
;

2
extra/documents/documents.factor
View File

@ -43,7 +43,7 @@ TUPLE: document locs ;
] if ;
: each-line ( from to quot -- )
pick pick = [
2over = [
3drop
] [
>r [ first ] 2apply 1+ dup <slice> r> each

2
extra/id3/id3.factor
View File

@ -64,7 +64,7 @@ C: <extended-header> extended-header
} cond ;
: (read-frame) ( id -- frame )
read-frame-size read-frame-flags pick pick read-frame-data <frame> ;
read-frame-size read-frame-flags 2over read-frame-data <frame> ;
: read-frame ( -- frame/f )
read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ;

2
extra/math/vectors/vectors.factor
View File

@ -25,7 +25,7 @@ IN: math.vectors
: normalize ( u -- v ) dup norm v/n ;
: set-axis ( u v axis -- w )
dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;
dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ;
HINTS: vneg { float-array } { array } ;
HINTS: norm-sq { float-array } { array } ;

2
extra/parser-combinators/parser-combinators.factor
View File

@ -38,7 +38,7 @@ C: <parse-result> parse-result
[ [ >upper ] 2apply ] when sequence= ;
: string-head? ( str head ignore-case -- ? )
pick pick shorter? [
2over shorter? [
3drop f
] [
>r [ length head-slice ] keep r> string=

15
extra/space-invaders/space-invaders.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
shuffle arrays io.files combinators kernel.private
ui.gestures ui.gadgets ui.render opengl.gl system
threads concurrency match ui byte-arrays combinators.lib
sequences.private ;
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
sequences kernel shuffle arrays io.files combinators ui.gestures
ui.gadgets ui.render opengl.gl system threads concurrency match
ui byte-arrays combinators.lib ;
IN: space-invaders
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
@ -191,7 +190,7 @@ M: space-invaders reset ( cpu -- )
: gui-step ( cpu -- )
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions dispatch ] keep
[ swap instructions case ] keep
[ cpu-pc HEX: FFFF bitand ] keep
set-cpu-pc ;
@ -345,11 +344,13 @@ M: space-invaders update-video ( value addr cpu -- )
#! concurrent process. Messages can be sent to
#! signal key presses, etc.
dup invaders-gadget-quit? [
2drop
] [
[ sync-frame ] dip
[ invaders-gadget-cpu gui-frame ] keep
[ relayout-1 ] keep
invaders-process
] unless ;
] if ;
M: invaders-gadget graft* ( gadget -- )
dup invaders-gadget-cpu init-sounds

2
extra/sudoku/sudoku.factor
View File

@ -35,7 +35,7 @@ DEFER: search
{ [ t ] [ assume ] }
} cond ;
: solve ( x y -- ) 9 [ 1+ pick pick attempt ] each 2drop ;
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
: board. ( board -- )
standard-table-style [

2
extra/xmode/marker/state/state.factor
View File

@ -26,7 +26,7 @@ SYMBOL: delegate-end-escaped?
current-rule-set rule-set-keywords ;
: token, ( from to id -- )
pick pick = [ 3drop ] [ >r line get subseq r> <token> , ] if ;
2over = [ 3drop ] [ >r line get subseq r> <token> , ] if ;
: prev-token, ( id -- )
>r last-offset get position get r> token,