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

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

db4
Eduardo Cavazos 2008-07-20 05:01:21 -05:00
parent b62dbb887c 637cc63e0c
commit cbbc476f55
152 changed files with 5907 additions and 394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/arrays/arrays.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private math math.private sequences
sequences.private ;
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: arrays
M: array clone (clone) ;
M: array length array-capacity ;
M: array length length>> ;
M: array nth-unsafe >r >fixnum r> array-nth ;
M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
M: array resize resize-array ;

5
core/assocs/assocs.factor
View File

@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
] [
3dup nth-unsafe at*
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
] if ; inline
] if ; inline recursive
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: zip ( keys values -- alist )
2array flip ; inline
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline

4
core/binary-search/binary-search.factor
View File

@ -16,7 +16,7 @@ IN: binary-search
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
: (search) ( quot seq -- i elt )
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
@ -25,7 +25,7 @@ IN: binary-search
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
} case
] if ; inline
] if ; inline recursive
PRIVATE>

2
core/bootstrap/compiler/compiler.factor
View File

@ -37,7 +37,7 @@ nl
array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth
array-nth set-array-nth
wrap probe

29
core/bootstrap/primitives.factor
View File

@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts
classes classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union classes.intersection classes.predicate
compiler.units bootstrap.image.private io.files accessors combinators ;
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -225,7 +226,9 @@ bi
{ "imaginary" { "real" "math" } read-only }
} define-builtin
"array" "arrays" create { } define-builtin
"array" "arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
"wrapper" "kernel" create {
{ "wrapped" read-only }
@ -261,7 +264,9 @@ bi
{ "sub-primitive" read-only }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"byte-array" "byte-arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
"callstack" "kernel" create { } define-builtin
@ -306,9 +311,12 @@ tuple
} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri
{
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ]
} cleave
(( obj quot -- curry )) define-declared
"compose" "kernel" create
@ -319,9 +327,12 @@ tuple
} prepare-slots define-tuple-class
"compose" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri
{
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ]
} cleave
(( quot1 quot2 -- compose )) define-declared
! Sub-primitive words

1
core/bootstrap/stage1.factor
View File

@ -32,7 +32,6 @@ load-help? off
"libc" require
"io.streams.c" require
"io.thread" require
"vocabs.loader" require
"syntax" require

2
core/bootstrap/stage2.factor
View File

@ -56,6 +56,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
"io.thread" require
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when

1
core/bootstrap/syntax.factor
View File

@ -59,6 +59,7 @@ IN: bootstrap.syntax
"flushable"
"foldable"
"inline"
"recursive"
"parsing"
"t"
"{"

4
core/byte-arrays/byte-arrays.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien.accessors sequences
USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ;
IN: byte-arrays
M: byte-array clone (clone) ;
M: byte-array length array-capacity ;
M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline

2
core/classes/tuple/tuple.factor
View File

@ -91,7 +91,7 @@ ERROR: bad-superclass class ;
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
2dup array-capacity fixnum<
2dup 1 slot fixnum<
[ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline

8
core/combinators/combinators.factor
View File

@ -90,10 +90,10 @@ ERROR: no-case ;
: <buckets> ( initial length -- array )
next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( assoc initial quot -- buckets )
spin [ length <buckets> ] keep
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
nip ; inline
: distribute-buckets ( alist initial quot -- buckets )
swapd [ >r dup first r> call 2array ] curry map
[ length <buckets> dup ] keep
[ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets

5
core/dequeues/dequeues.factor
View File

@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value )
[ peek-back ] [ pop-back* ] bi ;
: slurp-dequeue ( dequeue quot -- )
over dequeue-empty? [ 2drop ] [
[ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
] if ; inline
[ drop [ dequeue-empty? not ] curry ]
[ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
MIXIN: dequeue

4
core/dlists/dlists.factor
View File

@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ;
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ;
: (dlist-find-node) ( dlist-node quot -- node/f ? )
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
] [ 2drop f f ] if ; inline
] [ 2drop f f ] if ; inline recursive
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline

18
core/effects/effects.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators accessors ;
combinators accessors arrays ;
IN: effects
TUPLE: effect in out terminated? ;
@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ;
[ t ]
} cond 2nip ;
GENERIC: (stack-picture) ( obj -- str )
M: string (stack-picture) ;
M: word (stack-picture) name>> ;
M: integer (stack-picture) drop "object" ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: word effect>string name>> ;
M: integer effect>string drop "object" ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
[ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
[ [ effect>string % CHAR: \s , ] each ] "" make ;
: effect>string ( effect -- string )
M: effect effect>string ( effect -- string )
[
"( " %
[ in>> stack-picture % "-- " % ]
@ -51,6 +52,9 @@ M: word stack-effect
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
: stack-height ( word -- n )
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;

34
core/effects/parser/parser.factor
View File

@ -1,15 +1,31 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects ;
USING: lexer sets sequences kernel splitting effects summary
combinators debugger arrays parser ;
IN: effects.parser
: parse-effect ( end -- effect )
parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
DEFER: parse-effect
ERROR: bad-effect ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
: parse-effect-token ( end -- token/f )
scan tuck = [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan-word {
{ \ ( [ ")" parse-effect ] }
[ ]
} case 2array
] when
] if
] [
"Stack effect declaration must not contain ( or ((" throw
] if ;
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] [ drop ] produce ;
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;

3
core/generic/generic.factor
View File

@ -77,6 +77,9 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body inline?
"method-generic" word-prop inline? ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;

3
core/generic/standard/engines/tuple/tuple.factor
View File

@ -64,6 +64,9 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;

4
core/graphs/graphs.factor
View File

@ -37,14 +37,14 @@ SYMBOL: graph
SYMBOL: previous
: (closure) ( obj quot -- )
: (closure) ( obj quot: ( elt -- assoc ) -- )
over previous get key? [
2drop
] [
over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
] if ; inline
] if ; inline recursive
: closure ( obj quot -- assoc )
H{ } clone [

10
core/hashtables/hashtables.factor
View File

@ -12,7 +12,7 @@ TUPLE: hashtable
<PRIVATE
: wrap ( i array -- n )
array-capacity 1 fixnum-fast fixnum-bitand ; inline
length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i )
>r hashcode >fixnum dup fixnum+fast r> wrap ; inline
@ -27,10 +27,10 @@ TUPLE: hashtable
dup ((empty)) eq?
[ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if
] if ; inline
] if ; inline recursive
: key@ ( key hash -- array n ? )
array>> dup array-capacity 0 eq?
array>> dup length>> 0 eq?
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
@ -51,7 +51,7 @@ TUPLE: hashtable
] [
probe (new-key@)
] if
] if ; inline
] if ; inline recursive
: new-key@ ( key hash -- array n empty? )
array>> 2dup hash@ (new-key@) ; inline
@ -71,7 +71,7 @@ TUPLE: hashtable
: hash-large? ( hash -- ? )
[ count>> 3 fixnum*fast 1 fixnum+fast ]
[ array>> array-capacity ] bi fixnum> ; inline
[ array>> length>> ] bi fixnum> ; inline
: hash-stale? ( hash -- ? )
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline

3
core/inference/backend/backend.factor
View File

@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ;
[ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values
#! last -> #return or #values
#! node -> #if or #dispatch
1 reify-curries
call dup node,
pop-d drop

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

@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ;
[ { ascii } declare decode-char ] \ decode-char inlined?
] unit-test
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
! Later
! [ t ] [

19
core/inference/dataflow/dataflow.factor
View File

@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
TUPLE: #merge < node ;
! Phi node: merging is a sequence of sequences of values
TUPLE: #merge < node merging ;
: #merge ( -- node ) \ #merge all-out-node ;
@ -191,7 +192,7 @@ TUPLE: #declare < node ;
: #drop ( n -- #shuffle )
d-tail flatten-curries \ #shuffle in-node ;
: node-exists? ( node quot -- ? )
: node-exists? ( node quot: ( node -- ? ) -- ? )
over [
2dup 2slip rot [
2drop t
@ -201,7 +202,7 @@ TUPLE: #declare < node ;
] if
] [
2drop f
] if ; inline
] if ; inline recursive
GENERIC: calls-label* ( label node -- ? )
@ -223,21 +224,21 @@ SYMBOL: node-stack
: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
: iterate-nodes ( node quot: ( -- ) -- )
over [
[ swap >node call node> drop ] keep iterate-nodes
] [
2drop
] if ; inline
] if ; inline recursive
: (each-node) ( quot -- next )
: (each-node) ( quot: ( node -- ) -- next )
node@ [ swap call ] 2keep
node-children [
[
[ (each-node) ] keep swap
] iterate-nodes
] each drop
iterate-next ; inline
iterate-next ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
@ -260,14 +261,14 @@ SYMBOL: node-stack
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
dup >r call dup [
>>successor
successor>> dup successor>>
r> (transform-nodes)
] [
r> 2drop f >>successor drop
] if ; inline
] if ; inline recursive
: transform-nodes ( node quot -- new-node )
over [

21
core/inference/transforms/transforms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators math.bitfields
namespaces quotations assocs combinators
inference.backend inference.dataflow inference.state
classes.tuple classes.tuple.private effects summary hashtables
classes generic sets definitions generic.standard slots.private ;
@ -48,25 +48,6 @@ IN: inference.transforms
\ spread [ spread>quot ] 1 define-transform
! Bitfields
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform
! Tuple operations
: [get-slots] ( slots -- quot )
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;

5
core/io/encodings/encodings.factor
View File

@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ;
{ CHAR: \n [ line-ends\n ] }
} case ; inline
: ((read-until)) ( buf quot -- string/f sep/f )
! quot: -- char stop?
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call
[ >r drop "" like r> ]
[ pick push ((read-until)) ] if ; inline
[ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f )
100 <sbuf> swap ((read-until)) ; inline

7
core/kernel/kernel.factor
View File

@ -109,10 +109,13 @@ DEFER: if
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
: while ( pred body tail -- )
: loop ( pred: ( -- ? ) -- )
dup slip swap [ loop ] [ drop ] if ; inline recursive
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
>r >r dup slip r> r> roll
[ >r tuck 2slip r> while ]
[ 2nip call ] if ; inline
[ 2nip call ] if ; inline recursive
! Object protocol
GENERIC: hashcode* ( depth obj -- code )

4
core/listener/listener.factor
View File

@ -59,9 +59,7 @@ SYMBOL: error-hook
] recover ;
: until-quit ( -- )
quit-flag get
[ quit-flag off ]
[ listen until-quit ] if ; inline
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;

10
core/math/bitfields/bitfields-tests.factor
View File

@ -15,3 +15,13 @@ IN: math.bitfields.tests
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
[ 0 ] [ { } bitfield-quot call ] unit-test
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test

21
core/math/bitfields/bitfields.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences words ;
USING: arrays kernel math sequences words
namespaces inference.transforms ;
IN: math.bitfields
GENERIC: (bitfield) ( value accum shift -- newaccum )
@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum )
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform

2
core/math/integers/integers.factor
View File

@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
inline
inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ;

16
core/math/math.factor
View File

@ -124,21 +124,21 @@ M: float fp-nan?
PRIVATE>
: (each-integer) ( i n quot -- )
: (each-integer) ( i n quot: ( i -- ) -- )
[ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline
[ 3drop ] if-iterate? ; inline recursive
: (find-integer) ( i n quot -- i )
: (find-integer) ( i n quot: ( i -- ? ) -- i )
[
iterate-step roll
[ 2drop ] [ iterate-next (find-integer) ] if
] [ 3drop f ] if-iterate? ; inline
] [ 3drop f ] if-iterate? ; inline recursive
: (all-integers?) ( i n quot -- ? )
: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
[
iterate-step roll
[ iterate-next (all-integers?) ] [ 3drop f ] if
] [ 3drop t ] if-iterate? ; inline
] [ 3drop t ] if-iterate? ; inline recursive
: each-integer ( n quot -- )
iterate-prep (each-integer) ; inline
@ -152,7 +152,7 @@ PRIVATE>
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
: find-last-integer ( n quot -- i )
: find-last-integer ( n quot: ( i -- ? ) -- i )
over 0 < [
2drop f
] [
@ -161,4 +161,4 @@ PRIVATE>
] [
>r 1- r> find-last-integer
] if
] if ; inline
] if ; inline recursive

12
core/math/parser/parser-tests.factor
View File

@ -77,10 +77,6 @@ unit-test
[ "-101.0e-2" string>number number>string ]
unit-test
[ 5.0 ]
[ "10.0/2" string>number ]
unit-test
[ f ]
[ "1e1/2" string>number ]
unit-test
@ -104,3 +100,11 @@ unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test

22
core/math/parser/parser.factor
View File

@ -55,8 +55,9 @@ SYMBOL: negative?
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
"/" split1 (base>) >r whole-part r>
3dup and and [ / + ] [ 3drop f ] if ;
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? )
{
@ -66,20 +67,23 @@ SYMBOL: negative?
} cond ;
: string>integer ( str -- n/f )
"-" ?head swap
string>digits dup valid-digits?
[ radix get digits>integer ] [ drop f ] if ;
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
PRIVATE>
: base> ( str radix -- n/f )
[
"-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
[ string>integer ]
} cond
r> [ dup [ neg ] when ] when
CHAR: / over member? [
string>ratio
] [
CHAR: . over member? [
string>float
] [
string>integer
] if
] if
] with-radix ;
: string>number ( str -- n/f ) 10 base> ;

5
core/memory/memory.factor
View File

@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables
kernel.private sbufs growable assocs namespaces quotations
math strings combinators ;
: (each-object) ( quot -- )
next-object dup
[ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline
: (each-object) ( quot: ( obj -- ) -- )
[ next-object dup ] swap [ drop ] while ; inline
: each-object ( quot -- )
begin-scan (each-object) end-scan ; inline

2
core/optimizer/control/control.factor
View File

@ -70,8 +70,6 @@ M: #label collect-label-info*
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail

12
core/quotations/quotations.factor
View File

@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations
<PRIVATE
: uncurry dup 3 slot swap 4 slot ; inline
: uncompose dup 3 slot swap 4 slot ; inline
PRIVATE>
M: quotation call (call) ;
M: curry call dup 3 slot swap 4 slot call ;
M: curry call uncurry call ;
M: compose call dup 3 slot swap 4 slot slip call ;
M: compose call uncompose slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;

10
core/sequences/sequences.factor
View File

@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence
<PRIVATE
: array-capacity ( array -- n )
1 slot { array-capacity } declare ; inline
: array-nth ( n array -- elt )
swap 2 fixnum+fast slot ; inline
@ -241,7 +238,8 @@ INSTANCE: repetition immutable-sequence
] 3keep ; inline
: (copy) ( dst i src j n -- dst )
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
inline recursive
: prepare-subseq ( from to seq -- dst i src j n )
[ >r swap - r> new-sequence dup 0 ] 3keep
@ -653,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: halves ( seq -- first second )
dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot -- value )
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
@ -668,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
>r >r halves r> r>
[ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline
] if ; inline recursive
: cut ( seq n -- before after )
[ head ] [ tail ] 2bi ;

11
core/sorting/sorting.factor
View File

@ -52,14 +52,14 @@ TUPLE: merge
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
: (merge) ( merge quot -- )
: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
over r-done? [ drop dump-l ] [
over l-done? [ drop dump-r ] [
2dup decide
[ over r-next ] [ over l-next ] if
(merge)
] if
] if ; inline
] if ; inline recursive
: flip-accum ( merge -- )
dup [ accum>> ] [ accum1>> ] bi eq? [
@ -111,10 +111,9 @@ TUPLE: merge
[ merge ] 2curry each-chunk ; inline
: sort-loop ( merge quot -- )
2 swap
[ pick seq>> length pick > ]
[ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
[ ] while 3drop ; inline
[ 2 [ over seq>> length over > ] ] dip
[ [ 1 shift 2dup ] dip sort-pass ] curry
[ ] while 2drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip

2
core/splitting/splitting.factor
View File

@ -30,7 +30,7 @@ IN: splitting
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;

1
core/syntax/syntax.factor
View File

@ -89,6 +89,7 @@ IN: bootstrap.syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
"recursive" [ word make-recursive ] define-syntax
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax

2
core/threads/threads.factor
View File

@ -195,7 +195,7 @@ M: real sleep
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
>r [ loop ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack r>

9
core/words/words.factor
View File

@ -164,6 +164,9 @@ M: object redefined drop ;
: make-inline ( word -- )
t "inline" set-word-prop ;
: make-recursive ( word -- )
t "recursive" set-word-prop ;
: make-flushable ( word -- )
t "flushable" set-word-prop ;
@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- )
M: word reset-word
{
"unannotated-def"
"parsing" "inline" "foldable" "flushable"
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"constructing"
@ -222,6 +225,10 @@ ERROR: bad-create name vocab ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
GENERIC: inline? ( word -- ? )
M: word inline? "inline" word-prop ;
PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )

60
extra/backtrack/backtrack.factor
View File

@ -1,20 +1,68 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences namespaces fry ;
USING: kernel continuations combinators sequences quotations arrays namespaces
fry summary assocs math math.order macros ;
IN: backtrack
SYMBOL: failure
: amb ( seq -- elt )
failure get
'[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each
, continue ] callcc1 ;
ERROR: amb-failure ;
M: amb-failure summary drop "Backtracking failure" ;
: fail ( -- )
f amb drop ;
failure get [ continue ]
[ amb-failure ] if* ;
: require ( ? -- )
[ fail ] unless ;
MACRO: checkpoint ( quot -- quot' )
'[ failure get ,
'[ '[ failure set , continue ] callcc0
, failure set @ ] callcc0 ] ;
: number-from ( from -- from+n )
[ 1 + number-from ] checkpoint ;
<PRIVATE
: unsafe-number-from-to ( to from -- to from+n )
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
: number-from-to ( to from -- to from+n )
2dup < [ fail ] when unsafe-number-from-to ;
: amb-integer ( seq -- int )
length 1 - 0 number-from-to nip ;
MACRO: unsafe-amb ( seq -- quot )
dup length 1 =
[ first 1quotation ]
[ [ first ] [ rest ] bi
'[ , [ drop , unsafe-amb ] checkpoint ] ] if ;
PRIVATE>
: amb-lazy ( seq -- elt )
[ amb-integer ] [ nth ] bi ;
: amb ( seq -- elt )
dup empty?
[ drop fail f ]
[ unsafe-amb ] if ; inline
MACRO: amb-execute ( seq -- quot )
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
'[ , 0 unsafe-number-from-to nip , case ] ;
: if-amb ( true false -- )
[
[ { t f } amb ]
[ '[ @ require t ] ]
[ '[ @ f ] ]
tri* if
] with-scope ; inline

12
extra/benchmark/backtrack/backtrack.factor Normal file → Executable file
View File

@ -12,18 +12,6 @@ IN: benchmark.backtrack
: nop ;
MACRO: amb-execute ( seq -- quot )
[ length ] [ <enum> [ 1quotation ] assoc-map ] bi
'[ , amb , case ] ;
: if-amb ( true false -- )
[
[ { t f } amb ]
[ '[ @ require t ] ]
[ '[ @ f ] ]
tri* if
] with-scope ; inline
: do-something ( a b -- c )
{ + - * } amb-execute ;

4
extra/cocoa/enumeration/enumeration.factor
View File

@ -11,13 +11,13 @@ IN: cocoa.enumeration
] with-malloc
] with-malloc ; inline
:: (NSFastEnumeration-each) ( object quot state stackbuf count -- )
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ , void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline
] if ; inline recursive
: NSFastEnumeration-each ( object quot -- )
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline

10
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ;
: wait-for-mailbox ( mailbox timeout -- )
>r threads>> r> "mailbox" wait ;
: block-unless-pred ( mailbox timeout pred -- )
: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
pick check-disposed
pick data>> over dlist-contains? [
3drop
] [
>r 2dup wait-for-mailbox r> block-unless-pred
] if ; inline
] if ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox )
over check-disposed
@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r dip r> while-mailbox-empty
] [
2drop
] if ; inline
[ [ mailbox-empty? ] curry ] dip [ ] while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
3dup block-unless-pred

2
extra/concurrency/messaging/messaging-tests.factor
View File

@ -47,7 +47,7 @@ SYMBOL: exit
} match-cond ;
[ -5 ] [
[ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
[ 0 [ counter ] loop ] "Counter" spawn "counter" set
{ increment 10 } "counter" get send
{ decrement 15 } "counter" get send
[ value , self , ] { } make "counter" get send

72
extra/disjoint-set/disjoint-set.factor
View File

@ -1,72 +0,0 @@
USING: accessors arrays hints kernel locals math sequences ;
IN: disjoint-set
<PRIVATE
TUPLE: disjoint-set parents ranks counts ;
: count ( a disjoint-set -- n )
counts>> nth ; inline
: add-count ( p a disjoint-set -- )
[ count [ + ] curry ] keep counts>> swap change-nth ; inline
: parent ( a disjoint-set -- p )
parents>> nth ; inline
: set-parent ( p a disjoint-set -- )
parents>> set-nth ; inline
: link-sets ( p a disjoint-set -- )
[ set-parent ]
[ add-count ] 3bi ; inline
: rank ( a disjoint-set -- r )
ranks>> nth ; inline
: inc-rank ( a disjoint-set -- )
ranks>> [ 1+ ] change-nth ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
: representative ( a disjoint-set -- p )
2dup representative? [ drop ] [
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
: ranks ( a b disjoint-set -- r r )
[ rank ] curry bi@ ; inline
:: branch ( a b neg zero pos -- )
a b = zero [ a b < neg pos if ] if ; inline
PRIVATE>
: <disjoint-set> ( n -- disjoint-set )
[ >array ]
[ 0 <array> ]
[ 1 <array> ] tri
disjoint-set boa ;
: equiv-set-size ( a disjoint-set -- n )
[ representative ] keep count ;
: equiv? ( a b disjoint-set -- ? )
representatives = ; inline
:: equate ( a b disjoint-set -- )
a b disjoint-set representatives
2dup = [ 2drop ] [
2dup disjoint-set ranks
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
disjoint-set link-sets
] if ;
HINTS: equate disjoint-set ;
HINTS: representative disjoint-set ;
HINTS: equiv-set-size disjoint-set ;

0
extra/disjoint-set/authors.txt → extra/disjoint-sets/authors.txt
View File

88
extra/disjoint-sets/disjoint-sets.factor Normal file
View File

@ -0,0 +1,88 @@
! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables
assocs ;
IN: disjoint-sets
TUPLE: disjoint-set
{ parents hashtable read-only }
{ ranks hashtable read-only }
{ counts hashtable read-only } ;
<PRIVATE
: count ( a disjoint-set -- n )
counts>> at ; inline
: add-count ( p a disjoint-set -- )
[ count [ + ] curry ] keep counts>> swap change-at ; inline
: parent ( a disjoint-set -- p )
parents>> at ; inline
: set-parent ( p a disjoint-set -- )
parents>> set-at ; inline
: link-sets ( p a disjoint-set -- )
[ set-parent ] [ add-count ] 3bi ; inline
: rank ( a disjoint-set -- r )
ranks>> at ; inline
: inc-rank ( a disjoint-set -- )
ranks>> [ 1+ ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
PRIVATE>
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
2dup representative? [ drop ] [
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
<PRIVATE
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
: ranks ( a b disjoint-set -- r r )
[ rank ] curry bi@ ; inline
:: branch ( a b neg zero pos -- )
a b = zero [ a b < neg pos if ] if ; inline
PRIVATE>
: <disjoint-set> ( -- disjoint-set )
H{ } clone H{ } clone H{ } clone disjoint-set boa ;
GENERIC: add-atom ( a disjoint-set -- )
M: disjoint-set add-atom
[ dupd parents>> set-at ]
[ 0 -rot ranks>> set-at ]
[ 1 -rot counts>> set-at ]
2tri ;
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;
GENERIC: equiv? ( a b disjoint-set -- ? )
M: disjoint-set equiv? representatives = ;
GENERIC: equate ( a b disjoint-set -- )
M:: disjoint-set equate ( a b disjoint-set -- )
a b disjoint-set representatives
2dup = [ 2drop ] [
2dup disjoint-set ranks
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
disjoint-set link-sets
] if ;

0
extra/disjoint-set/summary.txt → extra/disjoint-sets/summary.txt
View File

0
extra/disjoint-set/tags.txt → extra/disjoint-sets/tags.txt
View File

24
extra/fry/fry-docs.factor
View File

@ -19,10 +19,11 @@ HELP: fry
HELP: '[
{ $syntax "code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."
"The easiest way to understand fried quotations is to look at some examples."
$nl
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
{ $code "{ 10 20 30 } '[ . ] each" }
@ -38,9 +39,10 @@ $nl
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
"{ 10 20 30 } [ 3 5 / ] map"
}
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ call . ] curry each"
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
@ -50,16 +52,17 @@ $nl
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } 1 '[ , _ / ] map"
"{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"
"{ 10 20 30 } 1 [ swap / ] curry map"
"{ 10 20 30 } [ 1 swap / ] map"
}
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"
{ $code
"[ >r X r> ]"
"[ X _ ]"
"[ [ X ] dip ]"
"'[ X _ ]"
}
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
@ -73,8 +76,11 @@ $nl
} ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."
$nl
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
{ $code
"'[ [ , key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 , + 4 , / ]"
@ -87,7 +93,7 @@ $nl
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
ARTICLE: "fry" "Fried quotations"
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."

2
extra/help/handbook/handbook.factor
View File

@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections"
{ $subsection "heaps" }
{ $subsection "graphs" }
{ $subsection "buffers" }
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;

2
extra/help/lint/lint.factor
View File

@ -29,7 +29,7 @@ IN: help.lint
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ (stack-picture) ] map
[ dup pair? [ first ] when effect>string ] map
prune natural-sort ;
: contains-funky-elements? ( element -- ? )

4
extra/io/monitors/monitors-tests.factor
View File

@ -55,7 +55,7 @@ os { winnt linux macosx } member? [
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
] [ ] [ ] while
] loop
"c1" get count-down
@ -64,7 +64,7 @@ os { winnt linux macosx } member? [
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
] [ ] [ ] while
] loop
"c2" get count-down
] "Monitor test thread" spawn drop

44
extra/irc/client/client-tests.factor
View File

@ -1,7 +1,7 @@
USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes ;
concurrency.mailboxes classes assocs ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
@ -20,28 +20,6 @@ IN: irc.client.tests
: with-dummy-client ( quot -- )
rot with-variable ; inline
! Parsing tests
irc-message new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
privmsg new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
"#factortest" >>name
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
{ "" } make-client dup "factorbot" set-nick current-irc-client [
{ t } [ irc> profile>> nickname>> me? ] unit-test
@ -64,21 +42,29 @@ privmsg new
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
profile>> nickname>> ] unit-test
profile>> nickname>> ] unit-test
{ join_ "#factortest" } [
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net MODE #factortest +ns"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} make-client dup "factorbot" set-nick
[ connect-irc ] keep 1 seconds sleep
join-messages>> 5 seconds mailbox-get-timeout
join-messages>> 1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi ] unit-test
! TODO: user join
! ":somedude!n=user@isp.net JOIN :#factortest"
{ +join+ "somebody" } [
{ ":somebody!n=somebody@some.where JOIN :#factortest"
} make-client dup "factorbot" set-nick
[ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
[ action>> ] [ nick>> ] bi
] unit-test
! TODO: channel message
! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
! TODO: direct private message
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"

121
extra/irc/client/client.factor
View File

@ -31,6 +31,20 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
TUPLE: irc-nick-listener < irc-listener name ;
SYMBOL: +server-listener+
! participant modes
SYMBOL: +operator+
SYMBOL: +voice+
SYMBOL: +normal+
: participant-mode ( n -- mode )
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
! participant changed actions
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
: <irc-server-listener> ( -- irc-server-listener )
@ -46,6 +60,9 @@ SYMBOL: +server-listener+
! Message objects
! ======================================
TUPLE: participant-changed nick action ;
C: <participant-changed> participant-changed
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
@ -70,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: to-listener ( message name -- )
GENERIC: to-listener ( message obj -- )
M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
[ to-listener ] [ drop ] if* ;
M: irc-listener to-listener ( message irc-listener -- )
in-messages>> mailbox-put ;
: remove-participant ( nick channel -- )
listener> [ participants>> delete-at ] [ drop ] if* ;
: remove-participant-from-all ( nick -- )
irc> listeners>>
[ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
assoc-each ;
: listeners-with-participant ( nick -- seq )
irc> listeners>> values
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
with filter ;
: add-participant ( nick mode channel -- )
: remove-participant-from-all ( nick -- )
dup listeners-with-participant [ delete-at ] with each ;
: add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ;
DEFER: me?
@ -142,12 +167,31 @@ DEFER: me?
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
: broadcast-message-to-listeners ( message -- )
irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
irc> listeners>> values [ to-listener ] with each ;
GENERIC: handle-participant-change ( irc-message -- )
M: join handle-participant-change ( join -- )
[ prefix>> parse-name +join+ <participant-changed> ]
[ trailing>> ] bi to-listener ;
M: part handle-participant-change ( part -- )
[ prefix>> parse-name +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: kick handle-participant-change ( kick -- )
[ who>> +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: quit handle-participant-change ( quit -- )
prefix>> parse-name
[ +part+ <participant-changed> ] [ listeners-with-participant ] bi
[ to-listener ] with each ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
+server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc> profile>> (>>nickname) ;
@ -162,34 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
[ maybe-forward-join ]
[ dup trailing>> to-listener ]
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
tri ;
{ [ maybe-forward-join ] ! keep
[ dup trailing>> to-listener ]
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ]
} cleave ;
M: part handle-incoming-irc ( part -- )
[ dup channel>> to-listener ] keep
[ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
M: kick handle-incoming-irc ( kick -- )
[ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
[ dup channel>> to-listener ]
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ]
tri ;
M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
} cleave ;
M: quit handle-incoming-irc ( quit -- )
[ prefix>> parse-name remove-participant-from-all ] keep
call-next-method ;
{ [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
[ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ]
[ ]
} cleave call-next-method ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ f ] if ;
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;
[ names-reply>participants ] [ channel>> listener> ] bi
[ (>>participants) ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
@ -200,8 +253,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
GENERIC: handle-outgoing-irc ( obj -- )
! M: irc-message handle-outgoing-irc ( irc-message -- )
! irc-message>string irc-print ;
M: irc-message handle-outgoing-irc ( irc-message -- )
irc-message>client-line irc-print ;
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
@ -213,11 +266,6 @@ M: part handle-outgoing-irc ( part -- )
! Reader/Writer
! ======================================
: irc-mailbox-get ( mailbox quot -- )
[ 5 seconds ] dip
'[ , , , [ mailbox-get-timeout ] dip call ]
[ drop ] recover ; inline
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
@ -225,7 +273,7 @@ DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ [ irc-disconnected ] dip to-listener ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ]
tri ;
@ -247,14 +295,14 @@ DEFER: (connect-irc)
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- )
irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- )
irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
irc> in-messages>> mailbox-get handle-incoming-irc ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@ -267,9 +315,8 @@ DEFER: (connect-irc)
} cond ;
: listener-loop ( name listener -- )
out-messages>> swap
'[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
irc-mailbox-get ;
out-messages>> mailbox-get maybe-annotate-with-name
irc> out-messages>> mailbox-put ;
: spawn-irc-loop ( quot name -- )
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip

37
extra/irc/messages/messages-tests.factor Normal file
View File

@ -0,0 +1,37 @@
USING: kernel tools.test accessors arrays qualified
irc.messages irc.messages.private ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
! Parsing tests
irc-message new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
privmsg new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
"#factortest" >>name
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
join new
":someuser!n=user@some.where JOIN :#factortest" >>line
"someuser!n=user@some.where" >>prefix
"JOIN" >>command
{ } >>parameters
"#factortest" >>trailing
1array
[ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test

8
extra/irc/messages/messages.factor
View File

@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ;
TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
irc-message new now >>timestamp
[ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
@ -30,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string )
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
@ -58,6 +63,8 @@ M: irc-message irc-message>server-line ( irc-message -- string )
: split-trailing ( string -- string string/f )
":" split1 ;
PRIVATE>
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
@ -82,4 +89,3 @@ M: irc-message irc-message>server-line ( irc-message -- string )
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
PRIVATE>

2
extra/irc/ui/load/load.factor
View File

@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ;
IN: irc.ui.load
: file-or ( path path -- path ) over exists? ? ;
: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;

85
extra/irc/ui/ui.factor
View File

@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids
io io.styles namespaces calendar calendar.format
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
io io.styles namespaces calendar calendar.format models
irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load ;
@ -18,11 +18,18 @@ SYMBOL: client
TUPLE: ui-window client tabs ;
TUPLE: irc-tab < frame listener client listmodel ;
: write-color ( str color -- )
foreground associate format ;
: red { 0.5 0 0 1 } ;
: green { 0 0.5 0 1 } ;
: blue { 0 0 1 1 } ;
: black { 0 0 0 1 } ;
: colors H{ { +operator+ { 0 0.5 0 1 } }
{ +voice+ { 0 0 1 1 } }
{ +normal+ { 0 0 0 1 } } } ;
: dot-or-parens ( string -- string )
dup empty? [ drop "." ]
@ -64,6 +71,14 @@ M: quit write-irc
" has left IRC" red write-color
trailing>> dot-or-parens red write-color ;
M: mode write-irc
"* " blue write-color
[ name>> write ] keep
" has applied mode " blue write-color
[ mode>> write ] keep
" to " blue write-color
channel>> write ;
M: irc-end write-irc
drop "* You have left IRC" red write-color ;
@ -84,20 +99,39 @@ M: irc-message write-irc
[ print-irc ]
[ listener get write-message ] bi ;
: display ( stream listener -- )
GENERIC: handle-inbox ( tab message -- )
: filter-participants ( assoc val -- alist )
[ >alist ] dip
'[ second , = ] filter ;
: update-participants ( tab -- )
[ listmodel>> ] [ listener>> participants>> ] bi
[ +operator+ filter-participants ]
[ +voice+ filter-participants ]
[ +normal+ filter-participants ] tri
append append swap set-model ;
M: participant-changed handle-inbox
drop update-participants ;
M: object handle-inbox
nip print-irc ;
: display ( stream tab -- )
'[ , [ [ t ]
[ , read-message print-irc ]
[ , dup listener>> read-message handle-inbox ]
[ ] while ] with-output-stream ] "ircv" spawn drop ;
: <irc-pane> ( listener -- pane )
: <irc-pane> ( tab -- tab pane )
<scrolling-pane>
[ <pane-stream> swap display ] keep ;
[ <pane-stream> swap display ] 2keep ;
TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( page pane listener -- client editor )
irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream
: <irc-editor> ( tab pane -- tab editor )
over irc-editor new-editor
swap listener>> >>listener swap <pane-stream> >>outstream
over client>> >>client ;
: editor-send ( irc-editor -- )
@ -113,25 +147,36 @@ irc-editor "general" f {
{ T{ key-down f f "ENTER" } editor-send }
} define-command-map
TUPLE: irc-page < frame listener client ;
: <irc-list> ( -- gadget model )
[ drop ]
[ first2 [ <label> ] dip >>color ]
{ } <model> [ <list> ] keep ;
: <irc-page> ( listener client -- irc-page )
irc-page new-frame
swap client>> >>client swap [ >>listener ] keep
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
: <irc-tab> ( listener client -- irc-tab )
irc-tab new-frame
swap client>> >>client swap >>listener
<irc-pane> [ <scroller> @center grid-add* ] keep
<irc-editor> <scroller> @bottom grid-add* ;
M: irc-page graft*
: <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab>
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
[ update-participants ] keep ;
: <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ;
M: irc-tab graft*
[ listener>> ] [ client>> ] bi
add-listener ;
M: irc-page ungraft*
M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi
remove-listener ;
: join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip
[ <irc-page> swap ] keep
[ <irc-channel-tab> swap ] keep
tabs>> add-page ;
: irc-window ( ui-window -- )
@ -142,12 +187,12 @@ M: irc-page ungraft*
: ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap
[ connect-irc ]
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
[ listeners>> +server-listener+ swap at over <irc-tab>
"Server" associate <tabbed> >>tabs ] bi ;
: server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
[ over join-channel ] each ;
[ over join-channel ] each drop ;
: main-run ( -- ) run-ircui ;

2
extra/koszul/koszul.factor
View File

@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

6
extra/locals/locals.factor
View File

@ -64,8 +64,8 @@ C: <quote> quote
local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
>r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
@ -275,7 +275,7 @@ M: wlet local-rewrite*
: parse-locals ( -- vars assoc )
")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals dup push-locals ;
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>

4
extra/math/functions/functions.factor
View File

@ -23,12 +23,12 @@ GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot -- )
: each-bit ( n quot: ( ? -- ) -- )
over 0 number= pick -1 number= or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
] if ; inline recursive
GENERIC: (^) ( x y -- z ) foldable

25
extra/optimizer/debugger/debugger.factor
View File

@ -3,8 +3,8 @@
USING: classes io kernel kernel.private math.parser namespaces
optimizer prettyprint prettyprint.backend sequences words arrays
match macros assocs sequences.private generic combinators
sorting math quotations accessors inference inference.dataflow
optimizer.specializers ;
sorting math quotations accessors inference inference.backend
inference.dataflow optimizer.specializers generator ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
@ -135,14 +135,21 @@ M: object node>quot
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
SYMBOL: pass-count
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
: dataflow>report ( node -- alist )
: count-optimization-passes ( node n -- node n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ r> ] if ;
: make-report ( word -- assoc )
[
word-dataflow nip 1 count-optimization-passes pass-count set
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
@ -164,14 +171,12 @@ SYMBOL: node-count
node-count set
] H{ } make-assoc ;
: quot-optimize-report ( quot -- report )
dataflow optimize dataflow>report ;
: word-optimize-report ( word -- report )
def>> quot-optimize-report ;
: report. ( report -- )
[
"==== Optimization passes:" print
pass-count get .
nl
"==== Total number of dataflow nodes:" print
node-count get .
@ -186,4 +191,4 @@ SYMBOL: node-count
] bind ;
: optimizer-report. ( word -- )
word-optimize-report report. ;
make-report report. ;

2
extra/project-euler/079/079.factor
View File

@ -35,7 +35,7 @@ IN: project-euler.079
] { } make ;
: find-source ( seq -- elt )
[ keys ] [ values ] bi diff prune
unzip diff prune
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )

7
extra/project-euler/186/186.factor
View File

@ -1,4 +1,4 @@
USING: circular disjoint-set kernel math math.ranges
USING: circular disjoint-sets kernel math math.ranges
sequences sequences.lib ;
IN: project-euler.186
@ -29,7 +29,10 @@ IN: project-euler.186
drop nip
] if ;
: <relation> ( n -- unionfind )
<disjoint-set> [ [ add-atom ] curry each ] keep ;
: euler186 ( -- n )
<generator> 0 1000000 <disjoint-set> (p186) ;
<generator> 0 1000000 <relation> (p186) ;
MAIN: euler186

16
extra/reports/optimizer/optimizer.factor
View File

@ -2,13 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs words sequences arrays compiler
tools.time io.styles io prettyprint vocabs kernel sorting
generator optimizer math math.order math.statistics combinators ;
generator optimizer math math.order math.statistics combinators
optimizer.debugger ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: table. ( alist -- )
20 short tail*
standard-table-style
@ -28,13 +25,12 @@ IN: report.optimizer
tri
] 2bi ; inline
: optimization-passes ( word -- n )
word-dataflow nip 1 count-optimization-passes nip ;
: optimizer-measurements ( -- alist )
all-words [ compiled>> ] filter
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark 2array
] { } map>assoc ;
[ dup [ optimization-passes ] benchmark 2array ] { } map>assoc ;
: optimizer-measurements. ( alist -- )
{

20
extra/sequences/deep/deep.factor
View File

@ -10,25 +10,25 @@ IN: sequences.deep
dup string? swap number? or not
] [ drop f ] if ;
: deep-each ( obj quot -- )
: deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch?
[ [ deep-each ] curry each ] [ 2drop ] if ; inline
[ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
: deep-map ( obj quot -- newobj )
: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
[ call ] keep over branch?
[ [ deep-map ] curry map ] [ drop ] if ; inline
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot -- seq )
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over >r
pusher >r deep-each r>
r> dup branch? [ like ] [ drop ] if ; inline
r> dup branch? [ like ] [ drop ] if ; inline recursive
: deep-find-from ( obj quot -- elt ? )
: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
] [ 2drop f f ] if
] if ; inline
] if ; inline recursive
: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
@ -37,10 +37,10 @@ IN: sequences.deep
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
: deep-change-each ( obj quot -- )
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
] curry change-each ] [ 2drop ] if ; inline
] curry change-each ] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;

4
extra/sorting/insertion/insertion.factor
View File

@ -2,13 +2,13 @@ USING: locals sequences kernel math ;
IN: sorting.insertion
<PRIVATE
:: insert ( seq quot n -- )
:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
n n 1- seq exchange
seq quot n 1- insert
] unless
] unless ; inline
] unless ; inline recursive
PRIVATE>
: insertion-sort ( seq quot -- )

5
extra/ui/cocoa/cocoa.factor
View File

@ -16,10 +16,7 @@ SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[
[
NSApp [ dup do-event ] [ ] [ ] while drop
ui-wait
] ui-try
[ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
TUPLE: pasteboard handle ;

2
extra/ui/freetype/freetype.factor
View File

@ -142,7 +142,7 @@ M: freetype-renderer string-height ( open-font string -- h )
i end < [
i j bitmap texture copy-pixel
bitmap texture end (copy-row)
] when ; inline
] when ; inline recursive
:: copy-row ( i j bitmap texture width width2 -- i j )
i j bitmap texture i width + (copy-row)

22
extra/ui/render/render-docs.factor
View File

@ -5,17 +5,17 @@ IN: ui.render
HELP: gadget
{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
{ $list
{ { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
{ { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
{ { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
{ { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
{ { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
{ { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
{ { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
{ { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
{ { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
{ { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
{ { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
{ { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
{ $notes

293
unfinished/compiler/cfg/alias/alias.factor Normal file
View File

@ -0,0 +1,293 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences
accessors vectors combinators sets compiler.vops compiler.cfg ;
IN: compiler.cfg.alias
! Alias analysis -- must be run after compiler.cfg.stack.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
!
! All heap-allocated objects which are loaded from the stack, or
! other object slots are pessimistically assumed to belong to
! the same alias class.
!
! Freshly-allocated objects get their own alias class.
!
! The data and retain stack pointer registers are treated
! uniformly, and each one gets its own alias class.
!
! Simple pseudo-C example showing load elimination:
!
! int *x, *y, z: inputs
! int a, b, c, d, e: locals
!
! Before alias analysis:
!
! a = x[2]
! b = x[2]
! c = x[3]
! y[2] = z
! d = x[2]
! e = y[2]
! f = x[3]
!
! After alias analysis:
!
! a = x[2]
! b = a /* ELIMINATED */
! c = x[3]
! y[2] = z
! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
! e = z /* ELIMINATED */
! f = c /* ELIMINATED */
!
! Simple pseudo-C example showing store elimination:
!
! Before alias analysis:
!
! x[0] = a
! b = x[n]
! x[0] = c
! x[1] = d
! e = x[0]
! x[1] = c
!
! After alias analysis:
!
! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
! b = x[n]
! x[0] = c
! /* x[1] = d */ /* ELIMINATED */
! e = c
! x[1] = c
! Map vregs -> alias classes
SYMBOL: vregs>acs
: check [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by %%allot, %peek and %%slot can
#! ever be used as valid inputs to %%slot and %%set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
vregs>acs get at check ;
! Map alias classes -> sequence of vregs
SYMBOL: acs>vregs
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
: aliases ( vreg -- vregs )
#! All vregs which may contain the same value as vreg.
vreg>ac ac>vregs ;
: each-alias ( vreg quot -- )
[ aliases ] dip each ; inline
! Map vregs -> slot# -> vreg
SYMBOL: live-slots
! Current instruction number
SYMBOL: insn#
! Load/store history, for dead store elimination
TUPLE: load insn# ;
TUPLE: store insn# ;
: new-action ( class -- action )
insn# get swap boa ; inline
! Maps vreg -> slot# -> sequence of loads/stores
SYMBOL: histories
: history ( vreg -- history ) histories get at ;
: set-ac ( vreg ac -- )
#! Set alias class of newly-seen vreg.
{
[ drop H{ } clone swap histories get set-at ]
[ drop H{ } clone swap live-slots get set-at ]
[ swap vregs>acs get set-at ]
[ acs>vregs get push-at ]
} 2cleave ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
#! value.
over [ live-slots get at at ] [ 2drop f ] if ;
: load-constant-slot ( value slot# vreg -- )
live-slots get at check set-at ;
: load-slot ( value slot#/f vreg -- )
over [ load-constant-slot ] [ 3drop ] if ;
: record-constant-slot ( slot# vreg -- )
#! A load can potentially read every store of this slot#
#! in that alias class.
[
history [ load new-action swap ?push ] change-at
] with each-alias ;
: record-computed-slot ( vreg -- )
#! Computed load is like a load of every slot touched so far
[
history values [ load new-action swap push ] each
] each-alias ;
: remember-slot ( value slot#/f vreg -- )
over
[ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
[ 2nip record-computed-slot ] if ;
SYMBOL: ac-counter
: next-ac ( -- n )
ac-counter [ dup 1+ ] change ;
! Alias class for objects which are loaded from the data stack
! or other object slots. We pessimistically assume that they
! can all alias each other.
SYMBOL: heap-ac
: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
: set-new-ac ( vreg -- ) next-ac set-ac ;
: kill-constant-set-slot ( slot# vreg -- )
[ live-slots get at delete-at ] with each-alias ;
: record-constant-set-slot ( slot# vreg -- )
history [
dup empty? [ dup peek store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
: kill-computed-set-slot ( ac -- )
[ live-slots get at clear-assoc ] each-alias ;
: remember-set-slot ( slot#/f vreg -- )
over [
[ record-constant-set-slot ]
[ kill-constant-set-slot ] 2bi
] [ nip kill-computed-set-slot ] if ;
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
SYMBOL: constants
: constant ( vreg -- n/f )
#! Return an %iconst value, or f if the vreg was not
#! assigned by an %iconst.
resolve constants get at ;
! We treat slot accessors and stack traffic alike
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: %peek insn-slot# n>> ;
M: %replace insn-slot# n>> ;
M: %%slot insn-slot# slot>> constant ;
M: %%set-slot insn-slot# slot>> constant ;
M: %peek insn-object stack>> ;
M: %replace insn-object stack>> ;
M: %%slot insn-object obj>> resolve ;
M: %%set-slot insn-object obj>> resolve ;
: init-alias-analysis ( -- )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
0 ac-counter set
next-ac heap-ac set
%data next-ac set-ac
%retain next-ac set-ac ;
GENERIC: analyze-aliases ( insn -- insn' )
M: %iconst analyze-aliases
dup [ value>> ] [ out>> ] bi constants get set-at ;
M: %%allot analyze-aliases
#! A freshly allocated object is distinct from any other
#! object.
dup out>> set-new-ac ;
M: read-op analyze-aliases
dup out>> set-heap-ac
dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip %copy boa analyze-aliases nip
] [
drop remember-slot
] if ;
: idempotent? ( value slot#/f vreg -- ? )
#! Are we storing a value back to the same slot it was read
#! from?
live-slot = ;
M: write-op analyze-aliases
dup
[ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
3dup idempotent? [
2drop 2drop nop
] [
[ remember-set-slot drop ] [ load-slot ] 3bi
] if ;
M: %copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
M: vop analyze-aliases ;
SYMBOL: live-stores
: compute-live-stores ( -- )
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat unique
live-stores set ;
GENERIC: eliminate-dead-store ( insn -- insn' )
: (eliminate-dead-store) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
drop nop
] unless
] when ;
M: %replace eliminate-dead-store
#! Writes to above the top of the stack can be pruned also.
#! This is sound since any such writes are not observable
#! after the basic block, and any reads of those locations
#! will have been converted to copies by analyze-slot,
#! and the final stack height of the basic block is set at
#! the beginning by compiler.cfg.stack.
dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
M: vop eliminate-dead-store ;
: alias-analysis ( insns -- insns' )
init-alias-analysis
[ insn# set analyze-aliases ] map-index
compute-live-stores
[ insn# set eliminate-dead-store ] map-index ;

1
unfinished/compiler/cfg/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

270
unfinished/compiler/cfg/builder/builder.factor Normal file
View File

@ -0,0 +1,270 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
compiler.cfg compiler.vops compiler.vops.builder
namespaces math inference.dataflow optimizer.allot combinators
math.order ;
IN: compiler.cfg.builder
! Convert dataflow IR to procedure CFG.
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
SYMBOL: values>vregs
SYMBOL: loop-nesting
GENERIC: convert* ( node -- )
GENERIC: convert ( node -- )
: init-builder ( -- )
H{ } clone values>vregs set
V{ } clone loop-nesting set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get
[
end-basic-block
dupd successors>> push
] when*
set-basic-block ;
: convert-nodes ( node -- )
dup basic-block get and [
[ convert ] [ successor>> convert-nodes ] bi
] [ drop ] if ;
: (build-cfg) ( node word -- )
init-builder
begin-basic-block
basic-block get swap procedures get set-at
%prolog emit
convert-nodes ;
: build-cfg ( node word -- procedures )
H{ } clone [
procedures [ (build-cfg) ] with-variable
] keep ;
: value>vreg ( value -- vreg )
values>vregs get at ;
: output-vreg ( value vreg -- )
swap values>vregs get set-at ;
: produce-vreg ( value -- vreg )
next-vreg [ output-vreg ] keep ;
: (load-inputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ '[ produce-vreg _ , %peek emit ] each-index ]
[ [ length neg ] dip %height emit ]
2bi
] if ;
: load-inputs ( node -- )
[ in-d>> %data (load-inputs) ]
[ in-r>> %retain (load-inputs) ]
bi ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ [ length ] dip %height emit ]
[ '[ value>vreg _ , %replace emit ] each-index ]
2bi
] if ;
: store-outputs ( node -- )
[ out-d>> %data (store-outputs) ]
[ out-r>> %retain (store-outputs) ]
bi ;
M: #push convert*
out-d>> [
[ produce-vreg ] [ value-literal ] bi
emit-literal
] each ;
M: #shuffle convert* drop ;
M: #>r convert* drop ;
M: #r> convert* drop ;
M: node convert
[ load-inputs ]
[ convert* ]
[ store-outputs ]
tri ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
[ load-inputs ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
[ store-outputs ]
bi ;
: intrinsic ( node quot -- )
[
init-intrinsic
[ intrinsic-inputs ]
swap
[ intrinsic-outputs ]
tri
] with-scope ; inline
USING: kernel.private math.private slots.private
optimizer.allot ;
: maybe-emit-fixnum-shift-fast ( node -- node )
dup dup in-d>> second node-literal? [
dup dup in-d>> second node-literal
'[ , emit-fixnum-shift-fast ] intrinsic
] [
dup param>> (emit-call)
] if ;
: emit-call ( node -- )
dup param>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
{ \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
{ \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
{ \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
{ \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
{ \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
{ \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
{ \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
{ \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
{ \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
{ \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
{ \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
{ \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
{ \ eq? [ [ emit-eq? ] intrinsic ] }
{ \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
{ \ float+ [ [ emit-float+ ] intrinsic ] }
{ \ float- [ [ emit-float- ] intrinsic ] }
{ \ float* [ [ emit-float* ] intrinsic ] }
{ \ float/f [ [ emit-float/f ] intrinsic ] }
{ \ float<= [ [ emit-float<= ] intrinsic ] }
{ \ float>= [ [ emit-float>= ] intrinsic ] }
{ \ float< [ [ emit-float< ] intrinsic ] }
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
{ \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
{ \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
{ \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
M: #call-label convert
dup param>> loop-nesting get at [
basic-block get successors>> push
end-basic-block
basic-block off
drop
] [
(emit-call)
] if* ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
: float-conditional ( in1 in2 branch -- )
[ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
: emit-if ( #if -- )
in-d>> first value>vreg
next-vreg dup f emit-literal
cc/= integer-conditional ;
: convert-nested ( node -- last-bb )
[
<basic-block>
[ set-basic-block ] keep
[ convert-nodes end-basic-block ] dip
basic-block get
] with-scope
[ basic-block get successors>> push ] dip ;
: convert-if-children ( #if -- )
children>> [ convert-nested ] map sift
<basic-block>
[ '[ , _ successors>> push ] each ]
[ set-basic-block ]
bi ;
: phi-inputs ( #if -- vregs-seq )
children>>
[ last-node ] map
[ #values? ] filter
[ in-d>> [ value>vreg ] map ] map ;
: phi-outputs ( #if -- vregs )
successor>> out-d>> [ produce-vreg ] map ;
: emit-phi ( #if -- )
[ phi-outputs ] [ phi-inputs ] bi %phi emit ;
M: #if convert
{
[ load-inputs ]
[ emit-if ]
[ convert-if-children ]
[ emit-phi ]
} cleave ;
M: #values convert drop ;
M: #merge convert drop ;
M: #entry convert drop ;
M: #declare convert drop ;
M: #terminate convert drop ;
M: #label convert
#! Labels create a new procedure.
[ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
M: #loop convert
#! Loops become part of the current CFG.
begin-basic-block
[ param>> basic-block get 2array loop-nesting get push ]
[ node-child convert-nodes ]
bi
loop-nesting get pop* ;
M: #return convert
param>> loop-nesting get key? [
%epilog emit
%return emit
] unless ;

47
unfinished/compiler/cfg/cfg.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg
! The id is a globally unique id used for fast hashcode* and
! equal? on basic blocks. The number is assigned by
! linearization.
TUPLE: basic-block < identity-tuple
id
number
instructions
successors
predecessors
stack-frame ;
SYMBOL: next-block-id
: <basic-block> ( -- basic-block )
basic-block new
next-block-id counter >>id
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors ;
M: basic-block hashcode* id>> nip ;
! Utilities
SYMBOL: visited-blocks
: visit-block ( basic-block quot -- )
over visited-blocks get 2dup key?
[ 2drop 2drop ] [ conjoin call ] if ; inline
: (each-block) ( basic-block quot -- )
'[
,
[ call ]
[ [ successors>> ] dip '[ , (each-block) ] each ]
2bi
] visit-block ; inline
: each-block ( basic-block quot -- )
H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
: copy-at ( from to assoc -- )
3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline

49
unfinished/compiler/cfg/elaboration/elaboration.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces math layouts sequences locals
combinators compiler.vops compiler.vops.builder
compiler.cfg.builder ;
IN: compiler.cfg.elaboration
! This pass must run before conversion to machine IR to ensure
! correctness.
GENERIC: elaborate* ( insn -- )
: slot-shift ( -- n )
tag-bits get cell log2 - ;
:: compute-slot-known-tag ( insn -- addr )
{ $1 $2 $3 $4 $5 } temps
init-intrinsic
$1 slot-shift %iconst emit ! load shift offset
$2 insn slot>> $1 %shr emit ! shift slot by shift offset
$3 insn tag>> %iconst emit ! load tag number
$4 $2 $3 %isub emit
$5 insn obj>> $4 %iadd emit ! compute slot offset
$5
;
:: compute-slot-any-tag ( insn -- addr )
{ $1 $2 $3 $4 } temps
init-intrinsic
$1 insn obj>> emit-untag ! untag object
$2 slot-shift %iconst emit ! load shift offset
$3 insn slot>> $2 %shr emit ! shift slot by shift offset
$4 $1 $3 %iadd emit ! compute slot offset
$4
;
: compute-slot ( insn -- addr )
dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
M: %%slot elaborate*
[ out>> ] [ compute-slot ] bi %load emit ;
M: %%set-slot elaborate*
[ in>> ] [ compute-slot ] bi %store emit ;
M: object elaborate* , ;
: elaboration ( insns -- insns )
[ [ elaborate* ] each ] { } make ;

9
unfinished/compiler/cfg/kill-nops/kill-nops.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel compiler.vops ;
IN: compiler.cfg.kill-nops
! Smallest compiler pass ever.
: kill-nops ( instructions -- instructions' )
[ nop? not ] filter ;

40
unfinished/compiler/cfg/live-ranges/live-ranges.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors math.order sequences
compiler.vops ;
IN: compiler.cfg.live-ranges
TUPLE: live-range from to ;
! Maps vregs to live ranges
SYMBOL: live-ranges
: def ( n vreg -- )
[ dup live-range boa ] dip live-ranges get set-at ;
: use ( n vreg -- )
live-ranges get at [ max ] change-to drop ;
GENERIC: compute-live-ranges* ( n insn -- )
M: nullary-op compute-live-ranges*
2drop ;
M: flushable-op compute-live-ranges*
out>> def ;
M: effect-op compute-live-ranges*
in>> use ;
M: unary-op compute-live-ranges*
[ out>> def ] [ in>> use ] 2bi ;
M: binary-op compute-live-ranges*
[ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
M: %store compute-live-ranges*
[ call-next-method ] [ addr>> use ] 2bi ;
: compute-live-ranges ( insns -- )
H{ } clone live-ranges set
[ swap compute-live-ranges* ] each-index ;

12
unfinished/compiler/cfg/predecessors/predecessors.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg kernel accessors sequences ;
IN: compiler.cfg.predecessors
! Pass to compute precedecessors.
: compute-predecessors ( procedure -- )
[
dup successors>>
[ predecessors>> push ] with each
] each-block ;

25
unfinished/compiler/cfg/simplifier/simplifier.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel
compiler.cfg
compiler.cfg.predecessors
compiler.cfg.stack
compiler.cfg.alias
compiler.cfg.write-barrier
compiler.cfg.elaboration
compiler.cfg.vn
compiler.cfg.vn.conditions
compiler.cfg.kill-nops ;
IN: compiler.cfg.simplifier
: simplify ( insns -- insns' )
normalize-height
alias-analysis
elaboration
value-numbering
eliminate-write-barrier
kill-nops ;
: simplify-cfg ( procedure -- procedure )
dup compute-predecessors
dup [ [ simplify ] change-instructions drop ] each-block ;

42
unfinished/compiler/cfg/stack/stack.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.vops ;
IN: compiler.cfg.stack
! Combine multiple stack height changes into one, done at the
! start of the basic block.
!
! Alias analysis and value numbering assume this optimization
! has been performed.
! Current data and retain stack height is stored in
! %data, %retain variables.
GENERIC: compute-heights ( insn -- )
M: %height compute-heights
[ n>> ] [ stack>> ] bi [ + ] change ;
M: object compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn )
M: %height normalize-height*
[ n>> ] [ stack>> ] bi [ swap - ] change nop ;
: (normalize-height) ( insn -- insn )
dup stack>> get '[ , + ] change-n ; inline
M: %peek normalize-height* (normalize-height) ;
M: %replace normalize-height* (normalize-height) ;
M: object normalize-height* ;
: normalize-height ( insns -- insns' )
0 %data set
0 %retain set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map ] with-scope ] bi
%data get dup zero? [ drop ] [ %data %height boa prefix ] if
%retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;

1
unfinished/compiler/cfg/summary.txt Normal file
View File

@ -0,0 +1 @@
Low-level optimizer operating on control flow graph SSA IR

53
unfinished/compiler/cfg/vn/conditions/conditions.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors compiler.vops
compiler.cfg.vn.graph
compiler.cfg.vn.expressions
compiler.cfg.vn.liveness
compiler.cfg.vn ;
IN: compiler.cfg.vn.conditions
! The CFG generator produces naive code for the following code
! sequence:
!
! fixnum< [ ... ] [ ... ] if
!
! The fixnum< comparison generates a boolean, which is then
! tested against f.
!
! Using value numbering, we optimize the comparison of a boolean
! against f where the boolean is the result of comparison.
: expr-f? ( expr -- ? )
dup op>> %iconst eq?
[ value>> \ f tag-number = ] [ drop f ] if ;
: comparison-with-f? ( insn -- expr/f ? )
#! The expr is a binary-op %icmp or %fcmp.
dup code>> cc/= eq? [
in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
] [ drop f f ] if ;
: of-boolean? ( expr -- expr/f ? )
#! The expr is a binary-op %icmp or %fcmp.
in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
: original-comparison ( expr -- in/f code/f )
[ in>> vn>vreg ] [ code>> ] bi ;
: eliminate-boolean ( insn -- in/f code/f )
comparison-with-f? [
of-boolean? [
original-comparison
] [ drop f f ] if
] [ drop f f ] if ;
M: cond-branch make-value-node
#! If the conditional branch is testing the result of an
#! earlier comparison against f, we only mark as live the
#! earlier comparison, so DCE will eliminate the boolean.
dup eliminate-boolean drop swap in>> or live-vreg ;
M: cond-branch eliminate
dup eliminate-boolean dup
[ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;

17
unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel compiler.vops compiler.cfg.vn.graph
compiler.cfg.vn.expressions ;
IN: compiler.cfg.vn.constant-fold
GENERIC: constant-fold ( insn -- insn' )
M: vop constant-fold ;
: expr>insn ( out constant-expr -- constant-op )
[ value>> ] [ op>> ] bi new swap >>value swap >>out ;
M: pure-op constant-fold
dup out>>
dup vreg>vn vn>expr
dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;

64
unfinished/compiler/cfg/vn/expressions/expressions.factor Normal file
View File

@ -0,0 +1,64 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes kernel math namespaces sorting
compiler.vops compiler.cfg.vn.graph ;
IN: compiler.cfg.vn.expressions
! Referentially-transparent expressions
TUPLE: expr op ;
TUPLE: nullary-expr < expr ;
TUPLE: unary-expr < expr in ;
TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
TUPLE: boolean-expr < unary-expr code ;
TUPLE: constant-expr < expr value ;
TUPLE: literal-expr < unary-expr object ;
! op is always %peek
TUPLE: peek-expr < expr loc ;
SYMBOL: input-expr-counter
: next-input-expr ( -- n )
input-expr-counter [ dup 1 + ] change ;
! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
TUPLE: input-expr < expr n ;
GENERIC: >expr ( insn -- expr )
M: %literal-table >expr
class nullary-expr boa ;
M: constant-op >expr
[ class ] [ value>> ] bi constant-expr boa ;
M: %literal >expr
[ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
M: unary-op >expr
[ class ] [ in>> vreg>vn ] bi unary-expr boa ;
M: binary-op >expr
[ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
binary-expr boa ;
M: commutative-op >expr
[ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
sort-pair commutative-expr boa ;
M: boolean-op >expr
[ class ] [ in>> vreg>vn ] [ code>> ] tri
boolean-expr boa ;
M: %peek >expr
[ class ] [ stack-loc ] bi peek-expr boa ;
M: flushable-op >expr
class next-input-expr input-expr boa ;
: init-expressions ( -- )
0 input-expr-counter set ;

37
unfinished/compiler/cfg/vn/graph/graph.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs biassocs accessors
math.order prettyprint.backend parser ;
IN: compiler.cfg.vn.graph
TUPLE: vn n ;
SYMBOL: vn-counter
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
: VN: scan-word vn boa parsed ; parsing
M: vn <=> [ n>> ] compare ;
M: vn pprint* \ VN: pprint-word n>> pprint* ;
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
: vn>expr ( vn -- expr ) exprs>vns get value-at ;
SYMBOL: vregs>vns
: vreg>vn ( vreg -- vn ) vregs>vns get at ;
: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
: set-vn ( vn vreg -- ) vregs>vns get set-at ;
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;

37
unfinished/compiler/cfg/vn/liveness/liveness.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs sets accessors compiler.vops
compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
IN: compiler.cfg.vn.liveness
! A set of VNs which are (transitively) used by effect-ops. This
! is precisely the set of VNs whose value is needed outside of
! the basic block.
SYMBOL: live-vns
GENERIC: live-expr ( expr -- )
: live-vn ( vn -- )
#! Mark a VN and all VNs used in its computation as live.
dup live-vns get key? [ drop ] [
[ live-vns get conjoin ] [ vn>expr live-expr ] bi
] if ;
: live-vreg ( vreg -- ) vreg>vn live-vn ;
M: expr live-expr drop ;
M: literal-expr live-expr in>> live-vn ;
M: unary-expr live-expr in>> live-vn ;
M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
: live? ( vreg -- ? )
dup vreg>vn tuck vn>vreg =
[ live-vns get key? ] [ drop f ] if ;
: init-liveness ( -- )
H{ } clone live-vns set ;
GENERIC: eliminate ( insn -- insn' )
M: flushable-op eliminate dup out>> live? ?nop ;
M: vop eliminate ;

43
unfinished/compiler/cfg/vn/propagate/propagate.factor Normal file
View File

@ -0,0 +1,43 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences kernel accessors
compiler.vops
compiler.cfg.vn.graph ;
IN: compiler.cfg.vn.propagate
! If two vregs compute the same value, replace references to
! the latter with the former.
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
GENERIC: propogate ( insn -- insn )
M: effect-op propogate
[ resolve ] change-in ;
M: unary-op propogate
[ resolve ] change-in ;
M: binary-op propogate
[ resolve ] change-in1
[ resolve ] change-in2 ;
M: %phi propogate
[ [ resolve ] map ] change-in ;
M: %%slot propogate
[ resolve ] change-obj
[ resolve ] change-slot ;
M: %%set-slot propogate
call-next-method
[ resolve ] change-obj
[ resolve ] change-slot ;
M: %store propogate
call-next-method
[ resolve ] change-addr ;
M: nullary-op propogate ;
M: flushable-op propogate ;

220
unfinished/compiler/cfg/vn/simplify/simplify.factor Normal file
View File

@ -0,0 +1,220 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math math.order
layouts locals
compiler.vops
compiler.cfg.vn.graph
compiler.cfg.vn.expressions ;
IN: compiler.cfg.vn.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
: constant ( val type -- expr ) swap constant-expr boa ;
: simplify-not ( in -- vn/expr/f )
{
{ [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
{ [ dup op>> %not = ] [ in>> ] }
[ drop f ]
} cond ;
: simplify-box-float ( in -- vn/expr/f )
{
{ [ dup op>> %%unbox-float = ] [ in>> ] }
[ drop f ]
} cond ;
: simplify-unbox-float ( in -- vn/expr/f )
{
{ [ dup literal-expr? ] [ object>> %fconst constant ] }
{ [ dup op>> %%box-float = ] [ in>> ] }
[ drop f ]
} cond ;
M: unary-expr simplify*
#! Note the copy propagation: a %copy always simplifies to
#! its source vn.
[ in>> vn>expr ] [ op>> ] bi {
{ %copy [ ] }
{ %not [ simplify-not ] }
{ %%box-float [ simplify-box-float ] }
{ %%unbox-float [ simplify-unbox-float ] }
[ 2drop f ]
} case ;
: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
: identity ( in1 in2 val type -- expr ) constant 2nip ;
: constant-fold? ( in1 in2 -- ? )
[ constant-expr? ] both? ;
:: constant-fold ( in1 in2 quot type -- expr )
in1 in2 constant-fold?
[ in1 value>> in2 value>> quot call type constant ]
[ f ]
if ; inline
: simplify-iadd ( in1 in2 -- vn/expr/f )
{
{ [ over izero? ] [ nip ] }
{ [ dup izero? ] [ drop ] }
[ [ + ] %iconst constant-fold ]
} cond ;
: simplify-imul ( in1 in2 -- vn/expr/f )
{
{ [ over ione? ] [ nip ] }
{ [ dup ione? ] [ drop ] }
[ [ * ] %iconst constant-fold ]
} cond ;
: simplify-and ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ 0 %iconst identity ] }
{ [ dup ineg-one? ] [ drop ] }
{ [ 2dup = ] [ drop ] }
[ [ bitand ] %iconst constant-fold ]
} cond ;
: simplify-or ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
{ [ dup ineg-one? ] [ -1 %iconst identity ] }
{ [ 2dup = ] [ drop ] }
[ [ bitor ] %iconst constant-fold ]
} cond ;
: simplify-xor ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
[ [ bitxor ] %iconst constant-fold ]
} cond ;
: simplify-fadd ( in1 in2 -- vn/expr/f )
{
{ [ over fzero? ] [ nip ] }
{ [ dup fzero? ] [ drop ] }
[ [ + ] %fconst constant-fold ]
} cond ;
: simplify-fmul ( in1 in2 -- vn/expr/f )
{
{ [ over fone? ] [ nip ] }
{ [ dup fone? ] [ drop ] }
[ [ * ] %fconst constant-fold ]
} cond ;
: commutative-operands ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi
over constant-expr? [ swap ] when ;
M: commutative-expr simplify*
[ commutative-operands ] [ op>> ] bi {
{ %iadd [ simplify-iadd ] }
{ %imul [ simplify-imul ] }
{ %and [ simplify-and ] }
{ %or [ simplify-or ] }
{ %xor [ simplify-xor ] }
{ %fadd [ simplify-fadd ] }
{ %fmul [ simplify-fmul ] }
[ 3drop f ]
} case ;
: simplify-isub ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
{ [ 2dup = ] [ 0 %iconst identity ] }
[ [ - ] %iconst constant-fold ]
} cond ;
: simplify-idiv ( in1 in2 -- vn/expr/f )
{
{ [ dup ione? ] [ drop ] }
[ [ /i ] %iconst constant-fold ]
} cond ;
: simplify-imod ( in1 in2 -- vn/expr/f )
{
{ [ dup ione? ] [ 0 %iconst identity ] }
{ [ 2dup = ] [ 0 %iconst identity ] }
[ [ mod ] %iconst constant-fold ]
} cond ;
: simplify-shl ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
{ [ over izero? ] [ drop ] }
[ [ shift ] %iconst constant-fold ]
} cond ;
: unsigned ( n -- n' )
cell-bits 2^ 1- bitand ;
: useless-shift? ( in1 in2 -- ? )
over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
: simplify-shr ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
{ [ over izero? ] [ drop ] }
{ [ 2dup useless-shift? ] [ drop in1>> ] }
[ [ neg shift unsigned ] %iconst constant-fold ]
} cond ;
: simplify-sar ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
{ [ over izero? ] [ drop ] }
{ [ 2dup useless-shift? ] [ drop in1>> ] }
[ [ neg shift ] %iconst constant-fold ]
} cond ;
: simplify-icmp ( in1 in2 -- vn/expr/f )
= [ +eq+ %cconst constant ] [ f ] if ;
: simplify-fsub ( in1 in2 -- vn/expr/f )
{
{ [ dup izero? ] [ drop ] }
[ [ - ] %fconst constant-fold ]
} cond ;
: simplify-fdiv ( in1 in2 -- vn/expr/f )
{
{ [ dup fone? ] [ drop ] }
[ [ /i ] %fconst constant-fold ]
} cond ;
M: binary-expr simplify*
[ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
{ %isub [ simplify-isub ] }
{ %idiv [ simplify-idiv ] }
{ %imod [ simplify-imod ] }
{ %shl [ simplify-shl ] }
{ %shr [ simplify-shr ] }
{ %sar [ simplify-sar ] }
{ %icmp [ simplify-icmp ] }
{ %fsub [ simplify-fsub ] }
{ %fdiv [ simplify-fdiv ] }
[ 3drop f ]
} case ;
M: expr simplify* drop f ;
: simplify ( expr -- vn )
dup simplify* {
{ [ dup not ] [ drop expr>vn ] }
{ [ dup expr? ] [ expr>vn nip ] }
{ [ dup vn? ] [ nip ] }
} cond ;

31
unfinished/compiler/cfg/vn/vn.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences compiler.vops
compiler.cfg.vn.graph
compiler.cfg.vn.expressions
compiler.cfg.vn.simplify
compiler.cfg.vn.liveness
compiler.cfg.vn.constant-fold
compiler.cfg.vn.propagate ;
IN: compiler.cfg.vn
: insn>vn ( insn -- vn ) >expr simplify ; inline
GENERIC: make-value-node ( insn -- )
M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
M: effect-op make-value-node in>> live-vreg ;
M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
M: nullary-op make-value-node drop ;
: init-value-numbering ( -- )
init-value-graph
init-expressions
init-liveness ;
: value-numbering ( instructions -- instructions )
init-value-numbering
[ [ make-value-node ] each ]
[ [ eliminate constant-fold propogate ] map ]
bi ;

26
unfinished/compiler/cfg/write-barrier/write-barrier.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
compiler.vops compiler.cfg ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
SYMBOL: hits
GENERIC: eliminate-write-barrier* ( insn -- insn' )
M: %%allot eliminate-write-barrier*
dup out>> hits get conjoin ;
M: %write-barrier eliminate-write-barrier*
dup in>> hits get key?
[ drop nop ] [ dup in>> hits get conjoin ] if ;
M: %copy eliminate-write-barrier*
dup in/out hits get copy-at ;
M: vop eliminate-write-barrier* ;
: eliminate-write-barrier ( insns -- insns )
H{ } clone hits set
[ eliminate-write-barrier* ] map ;

38
unfinished/compiler/frontend/frontend-docs.factor Normal file
View File

@ -0,0 +1,38 @@
USING: help.markup help.syntax sequences quotations words
compiler.tree stack-checker.errors ;
IN: compiler.frontend
ARTICLE: "specializers" "Word specializers"
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
$nl
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
$nl
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
$nl
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code
"\\ append"
"{ { string string } { array array } }"
"\"specializer\" set-word-prop"
}
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
HELP: dataflow
{ $values { "quot" quotation } { "dataflow" node } }
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: dataflow-with
{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: specialized-def
{ $values { "word" word } { "quot" quotation } }
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

17
unfinished/compiler/frontend/frontend-tests.factor Normal file
View File

@ -0,0 +1,17 @@
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
USE: inference.dataflow
{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
{ 1 0 }
[
[ [ iterate-next ] iterate-nodes ] with-node-iterator
] must-infer-as
{ 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 0 } [ [ ] map-children ] must-infer-as

79
unfinished/compiler/frontend/frontend.factor Normal file
View File

@ -0,0 +1,79 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces assocs
words generic generic.standard generic.standard.engines arrays
kernel.private combinators vectors stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree.builder ;
IN: compiler.frontend
: with-dataflow ( quot -- dataflow )
[ tree-builder new dataflow-visitor set ] prepose
with-infer first>> ; inline
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with
#! Not safe to call from inference transforms.
[
>vector meta-d set
f infer-quot
] with-dataflow nip ;
: dataflow ( quot -- dataflow ) f dataflow-with ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
[ drop ]
} cond ;
: word-dataflow ( word -- effect dataflow )
[
[
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] maybe-cannot-infer
] with-dataflow ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

21
unfinished/compiler/lvops/lvops.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.lvops
! Machine representation ("linear virtual operations"). Uses
! same operations as CFG basic blocks, except edges and branches
! are replaced by linear jumps (_b* instances).
TUPLE: _label label ;
! Unconditional jump to label
TUPLE: _b label ;
! Integer
TUPLE: _bi label in code ;
TUPLE: _bf label in code ;
! Dispatch table, jumps to one of following _address
! depending value of 'in'
TUPLE: _dispatch in ;
TUPLE: _address word ;

50
unfinished/compiler/machine/builder/builder.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces
compiler.cfg compiler.vops compiler.lvops ;
IN: compiler.machine.builder
SYMBOL: block-counter
: number-basic-block ( basic-block -- )
#! Make this fancy later.
dup number>> [ drop ] [
block-counter [ dup 1+ ] change >>number
[ , ] [
successors>> <reversed>
[ number-basic-block ] each
] bi
] if ;
: flatten-basic-blocks ( procedure -- blocks )
[
0 block-counter
[ number-basic-block ]
with-variable
] { } make ;
GENERIC: linearize-instruction ( basic-block insn -- )
M: object linearize-instruction
, drop ;
M: %b linearize-instruction
drop successors>> first number>> _b emit ;
: conditional-branch ( basic-block insn class -- )
[ successors>> ] 2dip
[ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
[ 2drop second number>> _b emit ]
3bi ; inline
M: %bi linearize-instruction _bi conditional-branch ;
M: %bf linearize-instruction _bf conditional-branch ;
: build-mr ( procedure -- insns )
[
flatten-basic-blocks [
[ number>> _label emit ]
[ dup instructions>> [ linearize-instruction ] with each ]
bi
] each
] { } make ;

39
unfinished/compiler/machine/debug/debug.factor Normal file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences assocs io
prettyprint inference generator optimizer compiler.vops
compiler.cfg.builder compiler.cfg.simplifier
compiler.machine.builder compiler.machine.simplifier ;
IN: compiler.machine.debug
: dataflow>linear ( dataflow word -- linear )
[
init-counter
build-cfg
[ simplify-cfg build-mr simplify-mr ] assoc-map
] with-scope ;
: linear. ( linear -- )
[
"==== " write swap .
[ . ] each
] assoc-each ;
: linearized-quot. ( quot -- )
dataflow optimize
"Anonymous quotation" dataflow>linear
linear. ;
: linearized-word. ( word -- )
dup word-dataflow nip optimize swap dataflow>linear linear. ;
: >basic-block ( quot -- basic-block )
dataflow optimize
[
init-counter
"Anonymous quotation" build-cfg
>alist first second simplify-cfg
] with-scope ;
: basic-block. ( basic-block -- )
instructions>> [ . ] each ;

18
unfinished/compiler/machine/simplifier/simplifier.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences.next compiler.lvops ;
IN: compiler.machine.simplifier
: useless-branch? ( next insn -- ? )
2dup [ _label? ] [ _b? ] bi* and
[ [ label>> ] bi@ = ] [ 2drop f ] if ;
: simplify-mr ( insns -- insns )
#! Remove unconditional branches to labels immediately
#! following.
[
[
tuck useless-branch?
[ drop ] [ , ] if
] each-next
] { } make ;

Some files were not shown because too many files have changed in this diff Show More