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

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

db4
Joe Groff 2009-08-14 10:55:05 -04:00
parent cfe8019ad1 2ed4425b7a
commit 6fe7fe72c7
818 changed files with 8012 additions and 5445 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms-tests.factor
View File

@ -1,6 +1,6 @@
IN: alarms.tests
USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ;
IN: alarms.tests
[ ] [
1 <count-down>

14
basis/alarms/alarms.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads ;
IN: alarms
TUPLE: alarm
@ -21,21 +21,21 @@ SYMBOL: alarm-thread
ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f )
dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup time>> alarms get-global heap-push*
swap entry>> >box
[ dup time>> alarms get-global heap-push* ]
[ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
dup [ swap interval>> time+ now max ] change-time register-alarm ;
dup '[ _ interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]

13
basis/alien/arrays/arrays.factor
View File

@ -11,6 +11,8 @@ M: array c-type ;
M: array c-type-class drop object ;
M: array c-type-boxed-class drop object ;
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
@ -31,7 +33,7 @@ M: array c-type-boxer-quot drop [ ] ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
@ -45,8 +47,9 @@ PREDICATE: string-type < pair
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type c-type-class drop object ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
@ -72,8 +75,8 @@ M: string-type box-return
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;

2
basis/alien/c-types/c-types-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
IN: alien.c-types.tests
CONSTANT: xyz 123

58
basis/alien/c-types/c-types.factor
View File

@ -13,17 +13,20 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
TUPLE: abstract-c-type
{ class class initial: object }
boxer
{ boxed-class class initial: object }
{ boxer-quot callable }
unboxer
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
{ reg-class initial: int-regs }
size
align
align ;
TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align? ;
: <c-type> ( -- type )
@ -70,10 +73,16 @@ M: string c-type ( name -- type )
GENERIC: c-type-class ( name -- class )
M: c-type c-type-class class>> ;
M: abstract-c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
M: string c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
@ -82,7 +91,7 @@ M: string c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: c-type c-type-boxer-quot boxer-quot>> ;
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
@ -94,15 +103,15 @@ M: string c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: c-type c-type-unboxer-quot unboxer-quot>> ;
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-reg-class ( name -- reg-class )
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-reg-class reg-class>> ;
M: c-type c-type-rep rep>> ;
M: string c-type-reg-class c-type c-type-reg-class ;
M: string c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
@ -118,7 +127,7 @@ M: string c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: c-type c-type-align align>> ;
M: abstract-c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
@ -129,13 +138,11 @@ M: c-type c-type-stack-align? stack-align?>> ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
dup c-type-reg-class
swap c-type-boxer [ "No boxer" throw ] unless*
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n ctype -- )
dup c-type-reg-class
swap c-type-unboxer [ "No unboxer" throw ] unless*
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n ctype -- )
@ -169,7 +176,7 @@ GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: c-type heap-size size>> ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
@ -300,6 +307,7 @@ CONSTANT: primitive-types
[
<c-type>
c-ptr >>class
c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
@ -311,6 +319,7 @@ CONSTANT: primitive-types
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
@ -321,6 +330,7 @@ CONSTANT: primitive-types
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
@ -331,6 +341,7 @@ CONSTANT: primitive-types
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
@ -341,6 +352,7 @@ CONSTANT: primitive-types
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
@ -351,6 +363,7 @@ CONSTANT: primitive-types
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
@ -361,6 +374,7 @@ CONSTANT: primitive-types
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
@ -371,6 +385,7 @@ CONSTANT: primitive-types
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
@ -381,6 +396,7 @@ CONSTANT: primitive-types
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
@ -391,6 +407,7 @@ CONSTANT: primitive-types
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
@ -401,6 +418,7 @@ CONSTANT: primitive-types
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
@ -420,25 +438,27 @@ CONSTANT: primitive-types
<c-type>
float >>class
float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
single-float-rep >>rep
[ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
float >>class
float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
double-float-rep >>rep
[ >float ] >>unboxer-quot
"double" define-primitive-type

6
basis/alien/complex/complex-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
namespaces ;
namespaces math ;
IN: alien.complex.tests
C-STRUCT: complex-holder
@ -16,3 +16,7 @@ C-STRUCT: complex-holder
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
[ number ] [ "complex-double" c-type-boxed-class ] unit-test

2
basis/alien/complex/complex.factor
View File

@ -10,4 +10,4 @@ IN: alien.complex
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
>>
>>

4
basis/alien/complex/functor/functor-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex.functor ;
IN: alien.complex.functor.tests

1
basis/alien/complex/functor/functor.factor
View File

@ -30,6 +30,7 @@ define-struct
T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
drop
;FUNCTOR

4
basis/alien/destructors/destructors-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.destructors ;
IN: alien.destructors.tests

6
basis/alien/fortran/fortran.factor
View File

@ -357,15 +357,15 @@ M: character-type (<fortran-result>)
: (shuffle-map) ( return parameters -- ret par )
[
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
[ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
: (fortran-in-shuffle) ( ret par -- seq )
[ [ second ] bi@ <=> ] sort append ;
[ second ] sort-with append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;

2
basis/alien/libraries/libraries-tests.factor
View File

@ -1,5 +1,5 @@
IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ;
IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test

2
basis/alien/structs/structs-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces layouts ;
IN: alien.structs.tests
C-STRUCT: bar
{ "int" "x" }

22
basis/alien/structs/structs.factor
View File

@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
quotations byte-arrays ;
IN: alien.structs
TUPLE: struct-type
size
align
fields
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
return-in-registers? ;
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
M: struct-type c-type ;
M: struct-type heap-size size>> ;
M: struct-type c-type-class drop byte-array ;
M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type c-type-boxer-quot boxer-quot>> ;
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@ -56,6 +38,8 @@ M: struct-type stack-size
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type new
byte-array >>class
byte-array >>boxed-class
swap >>fields
swap >>align
swap >>size

4
basis/alien/syntax/syntax.factor
View File

@ -31,8 +31,10 @@ SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;

2
basis/ascii/ascii-tests.factor
View File

@ -10,7 +10,7 @@ IN: ascii.tests
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
[ LETTER? [ 1 + ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

4
basis/base64/base64.factor
View File

@ -34,7 +34,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1+ [ 76 = [ crlf ] when ]
1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
@ -48,7 +48,7 @@ SYMBOL: column
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
[ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

2
basis/biassocs/biassocs-tests.factor
View File

@ -1,5 +1,5 @@
IN: biassocs.tests
USING: biassocs assocs namespaces tools.test ;
IN: biassocs.tests
<bihash> "h" set

10
basis/binary-search/binary-search-tests.factor
View File

@ -1,5 +1,5 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

4
basis/bit-arrays/bit-arrays.factor
View File

@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
dup 0 = [
<bit-array>
] [
[ log2 1+ <bit-array> 0 ] keep
[ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1+ ] [ -8 shift ] bi*
[ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;

2
basis/bit-sets/bit-sets-tests.factor
View File

@ -1,5 +1,5 @@
IN: bit-sets.tests
USING: bit-sets tools.test bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -1,5 +1,5 @@
IN: bit-vectors.tests
USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test

1
basis/bitstreams/bitstreams-tests.factor
View File

@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
io.streams.byte-array ;
IN: bitstreams.tests
[ BIN: 1111111111 ]
[
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

2
basis/bitstreams/bitstreams.factor
View File

@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
[ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline

40
basis/bootstrap/compiler/timing/timing.factor
View File

@ -1,38 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
compiler.cfg.stacks.finalize compiler.cfg.stacks.global
compiler.codegen compiler.tree.builder compiler.tree.optimizer
kernel make sequences tools.annotations tools.crossref ;
USING: accessors kernel make sequences tools.annotations tools.crossref ;
QUALIFIED: compiler.cfg.builder
QUALIFIED: compiler.cfg.linear-scan
QUALIFIED: compiler.cfg.mr
QUALIFIED: compiler.cfg.optimizer
QUALIFIED: compiler.cfg.stacks.finalize
QUALIFIED: compiler.cfg.stacks.global
QUALIFIED: compiler.codegen
QUALIFIED: compiler.tree.builder
QUALIFIED: compiler.tree.optimizer
IN: bootstrap.compiler.timing
: passes ( word -- seq )
def>> uses [ vocabulary>> "compiler." head? ] filter ;
: high-level-passes ( -- seq ) \ optimize-tree passes ;
: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
: low-level-passes ( -- seq ) \ optimize-cfg passes ;
: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
: machine-passes ( -- seq ) \ build-mr passes ;
: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
: all-passes ( -- seq )
[
\ build-tree ,
\ optimize-tree ,
\ compiler.tree.builder:build-tree ,
\ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
\ build-cfg ,
\ compute-global-sets ,
\ finalize-stack-shuffling ,
\ optimize-cfg ,
\ compiler.cfg.builder:build-cfg ,
\ compiler.cfg.stacks.global:compute-global-sets ,
\ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
\ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
\ compute-live-sets ,
\ build-mr ,
\ compiler.cfg.mr:build-mr ,
machine-passes %
linear-scan-passes %
\ generate ,
\ compiler.codegen:generate ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each

2
basis/bootstrap/image/image-tests.factor
View File

@ -1,6 +1,6 @@
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
IN: bootstrap.image.tests
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test

4
basis/bootstrap/image/image.factor
View File

@ -234,7 +234,7 @@ GENERIC: ' ( obj -- ptr )
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
@ -244,7 +244,7 @@ GENERIC: ' ( obj -- ptr )
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
[ nip length 1+ emit-fixnum ]
[ nip length 1 + emit-fixnum ]
[ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;

6
basis/bootstrap/image/upload/upload.factor
View File

@ -9,9 +9,9 @@ IN: bootstrap.image.upload
SYMBOL: upload-images-destination
: destination ( -- dest )
upload-images-destination get
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
upload-images-destination get
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
: checksums ( -- temp ) "checksums.txt" temp-file ;

2
basis/boxes/boxes-tests.factor
View File

@ -1,5 +1,5 @@
IN: boxes.tests
USING: boxes namespaces tools.test accessors ;
IN: boxes.tests
[ ] [ <box> "b" set ] unit-test

1
basis/byte-arrays/hex/hex.factor
View File

@ -8,4 +8,3 @@ SYNTAX: HEX{
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;

4
basis/cache/cache-tests.factor vendored
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test cache ;
IN: cache.tests

2
basis/cache/cache.factor vendored
View File

@ -38,6 +38,6 @@ PRIVATE>
: purge-cache ( cache -- )
dup max-age>> '[
[ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
[ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
[ values dispose-each ] dip
] change-assoc drop ;

2
basis/cairo/cairo-tests.factor
View File

@ -1,5 +1,5 @@
IN: cairo.tests
USING: cairo tools.test math.rectangles accessors ;
IN: cairo.tests
[ { 10 20 } ] [
{ 10 20 } [

6
basis/calendar/calendar-docs.factor
View File

@ -20,14 +20,14 @@ HELP: <date>
{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"2010 12 25 <date> >gmt midnight ."
{ $example "USING: accessors calendar prettyprint ;"
"2010 12 25 <date> instant >>gmt-offset ."
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
}
} ;
HELP: month-names
{ $values { "array" array } }
{ $values { "value" object } }
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;

27
basis/calendar/calendar.factor
View File

@ -34,25 +34,25 @@ C: <timestamp> timestamp
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
ERROR: not-a-month n ;
ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
[ not-a-month ] when-zero ;
PRIVATE>
: month-names ( -- array )
CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
} ;
}
: month-name ( n -- string )
check-month 1- month-names nth ;
check-month 1 - month-names nth ;
CONSTANT: month-abbreviations
{
@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
}
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
check-month 1 - month-abbreviations nth ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ;
e 153 m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' )
@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
[ 3 >>month 1 >>day ] when ;
: unless-zero ( n quot -- )
[ dup zero? [ drop ] ] dip if ; inline
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
12 /rem [ 1 - 12 ] when-zero swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@ -371,10 +368,10 @@ M: duration time-
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
[ 1 + 3 * 5 /i + ] keep 2 * +
] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n )
@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
year leap-year? [
year month day <date>
year 3 1 <date>
after=? [ 1+ ] when
after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )

14
basis/calendar/format/format.factor
View File

@ -68,8 +68,8 @@ M: array month. ( pair -- )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> concat write
[
[ 1+ day. ] keep
1+ + 7 mod zero? [ nl ] [ bl ] if
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each nl ;
M: timestamp month. ( timestamp -- )
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1+ 2array month. nl ] with each ;
12 [ 1 + 2array month. nl ] with each ;
M: timestamp year. ( timestamp -- )
year>> year. ;
@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until [
[ string>number ] [ length 10 swap ^ ] bi / +
[ string>number ] [ length 10^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
"," read-token day-abbreviations3 member? check-timestamp drop
read1 CHAR: \s assert=
read-sp checked-number >>day
read-sp month-abbreviations index 1+ check-timestamp >>month
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
"," read-token check-day-name
read1 CHAR: \s assert=
"-" read-token checked-number >>day
"-" read-token month-abbreviations index 1+ check-timestamp >>month
"-" read-token month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
: (cookie-string>timestamp-2) ( -- timestamp )
timestamp new
read-sp check-day-name
read-sp month-abbreviations index 1+ check-timestamp >>month
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>day
":" read-token checked-number >>hour
":" read-token checked-number >>minute

2
basis/channels/examples/examples.factor
View File

@ -7,7 +7,7 @@ locals sequences ;
IN: channels.examples
: (counter) ( channel n -- )
[ swap to ] 2keep 1+ (counter) ;
[ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;

2
basis/checksums/fnv1/fnv1.factor
View File

@ -1,9 +1,7 @@
! Copyright (C) 2009 Alaric Snell-Pym
! See http://factorcode.org/license.txt for BSD license.
USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ;
IN: checksums.fnv1
SINGLETON: fnv1-32

4
basis/checksums/md5/md5-tests.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays checksums checksums.md5 io.encodings.binary
io.streams.byte-array kernel math namespaces tools.test ;
IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

1
basis/circular/circular-tests.factor
View File

@ -2,6 +2,7 @@
! See http;//factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private
circular strings ;
IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

2
basis/circular/circular.factor
View File

@ -51,7 +51,7 @@ PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
[ [ 1+ ] change-length set-last ] if ;
[ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;

2
basis/cocoa/callbacks/callbacks.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
IN: cocoa.callbacks
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks

2
basis/cocoa/cocoa-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ;
IN: cocoa.tests
CLASS: {
{ +superclass+ "NSObject" }

2
basis/cocoa/messages/messages.factor
View File

@ -172,7 +172,7 @@ ERROR: no-objc-type name ;
[ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }

2
basis/cocoa/plists/plists-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.plists.tests
USING: tools.test cocoa.plists colors kernel hashtables
core-foundation.utilities core-foundation destructors
assocs cocoa.enumeration ;
IN: cocoa.plists.tests
[
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test

2
basis/colors/hsv/hsv-tests.factor
View File

@ -1,5 +1,5 @@
IN: colors.hsv.tests
USING: accessors kernel colors colors.hsv tools.test math ;
IN: colors.hsv.tests
: hsv>rgb ( h s v -- r g b )
[ 360 * ] 2dip

2
basis/columns/columns-tests.factor
View File

@ -1,5 +1,5 @@
IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ;
IN: columns.tests
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

12
basis/combinators/short-circuit/short-circuit-docs.factor
View File

@ -13,27 +13,27 @@ HELP: 0||
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
HELP: 1&&
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 1||
{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 2||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 3||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&

34
basis/combinators/short-circuit/smart/smart-tests.factor
View File

@ -1,32 +1,18 @@
USING: kernel math tools.test combinators.short-circuit.smart ;
IN: combinators.short-circuit.smart.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

10
basis/combinators/short-circuit/smart/smart.factor
View File

@ -1,13 +1,15 @@
USING: kernel sequences math stack-checker effects accessors macros
fry combinators.short-circuit ;
USING: kernel sequences math stack-checker effects accessors
macros fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
ERROR: cannot-determine-arity ;
: arity ( quots -- n )
first infer
dup terminated?>> [ "Cannot determine arity" throw ] when
effect-height neg 1+ ;
dup terminated?>> [ cannot-determine-arity ] when
effect-height neg 1 + ;
PRIVATE>

4
basis/combinators/smart/smart-docs.factor
View File

@ -28,7 +28,7 @@ HELP: output>array
{ $example
<" USING: combinators combinators.smart math prettyprint ;
9 [
{ [ 1- ] [ 1+ ] [ sq ] } cleave
{ [ 1 - ] [ 1 + ] [ sq ] } cleave
] output>array .">
"{ 8 10 81 }"
}
@ -71,7 +71,7 @@ HELP: sum-outputs
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
"10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
"10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
"20"
}
} ;

2
basis/combinators/smart/smart-tests.factor
View File

@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
10 [ 1- ] [ 1+ ] bi ;
10 [ 1 - ] [ 1 + ] bi ;
[ [ test-bi ] output>array ] must-infer
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test

1
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1 +0,0 @@
IN: compiler.cfg.alias-analysis.tests

6
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
accessors vectors combinators sets classes cpu.architecture compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
SYMBOL: ac-counter
: next-ac ( -- n )
ac-counter [ dup 1+ ] change ;
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
@ -226,7 +226,7 @@ M: ##read analyze-aliases*
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip \ ##copy new-insn analyze-aliases* nip
2nip any-rep \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;

11
basis/compiler/cfg/block-joining/block-joining.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel sequences math
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
compiler.cfg.predecessors compiler.cfg.utilities ;
IN: compiler.cfg.block-joining
! Joining blocks that are not calls and are connected by a single CFG edge.
! Predecessors must be recomputed after this. Also this pass does not
! update ##phi nodes and should therefore only run before stack analysis.
! This pass does not update ##phi nodes and should therefore only run
! before stack analysis.
: join-block? ( bb -- ? )
{
[ kill-block? not ]
@ -27,8 +27,11 @@ IN: compiler.cfg.block-joining
[ join-instructions ] [ update-successors ] 2bi ;
: join-blocks ( cfg -- cfg' )
needs-predecessors
dup post-order [
dup join-block?
[ dup predecessor join-block ] [ drop ] if
] each
cfg-changed ;
cfg-changed predecessors-changed ;

4
basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
View File

@ -9,11 +9,11 @@ IN: compiler.cfg.branch-splitting.tests
: check-predecessors ( cfg -- )
[ get-predecessors ]
[ compute-predecessors drop ]
[ needs-predecessors drop ]
[ get-predecessors ] tri assert= ;
: check-branch-splitting ( cfg -- )
compute-predecessors
needs-predecessors
split-branches
check-predecessors ;

5
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math math.order
sequences assocs namespaces vectors fry arrays splitting
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
@ -81,7 +81,10 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
] if ;
: split-branches ( cfg -- cfg' )
needs-predecessors
dup [
dup split-branch? [ split-branch ] [ drop ] if
] each-basic-block
cfg-changed ;

12
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,15 +1,13 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
combinators make classes words cpu.architecture layouts
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
SYMBOL: spill-counts
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
@ -30,11 +28,11 @@ M: ##call compute-stack-frame*
M: _gc compute-stack-frame*
frame-required? on
stack-frame new swap gc-root-size>> >>gc-root-size
stack-frame new swap tagged-values>> length cells >>gc-root-size
request-stack-frame ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: _spill-area-size compute-stack-frame*
n>> stack-frame get (>>spill-area-size) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
@ -45,7 +43,7 @@ M: insn compute-stack-frame*
: compute-stack-frame ( insns -- )
frame-required? off
T{ stack-frame } clone stack-frame set
stack-frame new stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;

9
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -1,14 +1,15 @@
IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
arrays locals byte-arrays kernel.private math slots.private vectors sbufs
strings math.partial-dispatch strings.private ;
compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
strings.private ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
'[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
'[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [

37
basis/compiler/cfg/builder/builder.factor
View File

@ -19,6 +19,7 @@ compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
compiler.cfg.stacks.local
compiler.alien ;
IN: compiler.cfg.builder
@ -144,7 +145,7 @@ M: #dispatch emit-node
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
ds-pop ^^offset>slot i ##dispatch emit-if ;
ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
! #call
M: #call emit-node
@ -159,14 +160,32 @@ M: #push emit-node
literal>> ^^load-literal ds-push ;
! #shuffle
! Even though low level IR has its own dead code elimination pass,
! we try not to introduce useless ##peeks here, since this reduces
! the accuracy of global stack analysis.
: make-input-map ( #shuffle -- assoc )
! Assoc maps high-level IR values to stack locations.
[
[ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
[ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
] H{ } make-assoc ;
: make-output-seq ( values mapping input-map -- vregs )
'[ _ at _ at peek-loc ] map ;
: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
[ [ out-d>> ] 2dip make-output-seq ]
[ [ out-r>> ] 2dip make-output-seq ] 3bi ;
: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
[ [ in-d>> length neg inc-d ] dip ds-store ]
[ [ in-r>> length neg inc-r ] dip rs-store ]
bi-curry* bi ;
M: #shuffle emit-node
dup
H{ } clone
[ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
: emit-return ( -- )
@ -227,3 +246,5 @@ M: #copy emit-node drop ;
M: #enter-recursive emit-node drop ;
M: #phi emit-node drop ;
M: #declare emit-node drop ;

0
basis/compiler/cfg/cfg-tests.factor
View File

23
basis/compiler/cfg/cfg.factor
View File

@ -19,11 +19,28 @@ M: basic-block hashcode* nip id>> ;
V{ } clone >>predecessors
\ basic-block counter >>id ;
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
TUPLE: cfg { entry basic-block } word label
spill-area-size reps
post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ;
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
: <cfg> ( entry word label -- cfg )
cfg new
swap >>label
swap >>word
swap >>entry ;
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
: cfg-changed ( cfg -- cfg )
f >>post-order
f >>linear-order
f >>dominance-valid?
f >>loops-valid? ; inline
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
: with-cfg ( cfg quot: ( cfg -- ) -- )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;

4
basis/compiler/cfg/copy-prop/copy-prop.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors sequences grouping
combinators compiler.cfg.rpo compiler.cfg.renaming
compiler.cfg.instructions ;
compiler.cfg.instructions compiler.cfg.predecessors ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
@ -70,6 +70,8 @@ M: insn update-insn rename-insn-uses t ;
PRIVATE>
: copy-propagation ( cfg -- cfg' )
needs-predecessors
[ collect-copies ]
[ rename-copies ]
[ ]

37
basis/compiler/cfg/critical-edges/critical-edges-tests.factor
View File

@ -1,37 +0,0 @@
USING: accessors assocs compiler.cfg
compiler.cfg.critical-edges compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers cpu.architecture kernel namespaces
sequences tools.test compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges.tests
! Make sure we update phi nodes when splitting critical edges
: test-critical-edges ( -- )
cfg new 0 get >>entry
compute-predecessors
split-critical-edges ;
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
T{ ##return }
} 2 test-bb
0 { 1 2 } edges
1 2 edge
[ ] [ test-critical-edges ] unit-test
[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test

29
basis/compiler/cfg/critical-edges/critical-edges.factor
View File

@ -1,29 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences locals assocs fry
compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges
: critical-edge? ( from to -- ? )
[ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
: new-key ( new-key old-key assoc -- )
[ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
:: update-phis ( from to bb -- )
! Any phi nodes in 'to' which reference 'from'
! should now reference 'bb'.
to [ [ bb from ] dip inputs>> new-key ] each-phi ;
: split-critical-edge ( from to -- )
f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ;
: split-critical-edges ( cfg -- )
dup [
dup successors>> [
2dup critical-edge?
[ split-critical-edge ] [ 2drop ] if
] with each
] each-basic-block
cfg-changed
drop ;

9
basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel locals sequences lexer
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg ;
compiler.cfg.predecessors compiler.cfg ;
IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets dfa -- set )
GENERIC: join-sets ( sets bb dfa -- set )
GENERIC: transfer-set ( in-set bb dfa -- out-set )
GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
@ -23,7 +23,7 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
bb dfa predecessors [ out-sets at ] map dfa join-sets ;
bb dfa predecessors [ out-sets at ] map bb dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
@ -48,6 +48,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
] when ; inline
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
cfg needs-predecessors drop
H{ } clone :> in-sets
H{ } clone :> out-sets
cfg dfa <dfa-worklist> :> work-list
@ -55,7 +56,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
in-sets
out-sets ; inline
M: dataflow-analysis join-sets drop assoc-refine ;
M: dataflow-analysis join-sets 2drop assoc-refine ;
FUNCTOR: define-analysis ( name -- )

72
basis/compiler/cfg/dce/dce-tests.factor
View File

@ -11,62 +11,62 @@ IN: compiler.cfg.dce.tests
entry>> instructions>> ;
[ V{
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
T{ ##replace { src V int-regs 3 } { loc D 0 } }
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
T{ ##replace { src V int-regs 3 } { loc D 0 } }
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
[ V{
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
T{ ##replace { src V int-regs 1 } { loc D 0 } }
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test

4
basis/compiler/cfg/dce/dce.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
compiler.cfg.rpo ;
compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
@ -95,6 +95,8 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
needs-predecessors
init-dead-code
dup
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]

24
basis/compiler/cfg/debugger/debugger.factor
View File

@ -4,11 +4,12 @@ USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config assocs
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
cpu.architecture compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
compiler.cfg.utilities compiler.cfg.def-use
compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -23,8 +24,10 @@ M: word test-cfg
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
[
optimize-cfg
build-mr
] with-cfg
] map ;
: insn. ( insn -- )
@ -41,11 +44,6 @@ M: word test-cfg
] each ;
! Prettyprinting
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
@ -72,3 +70,11 @@ M: rs-loc pprint* \ R pprint-loc ;
1 { 2 3 } edges
2 4 edge
3 4 edge ;
: fake-representations ( cfg -- )
post-order [
instructions>>
[ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
map concat
] map concat
[ int-rep ] H{ } map>assoc representations set ;

31
basis/compiler/cfg/def-use/def-use-tests.factor
View File

@ -8,30 +8,29 @@ compiler.cfg
compiler.cfg.debugger
compiler.cfg.instructions
compiler.cfg.registers ;
IN: compiler.cfg.def-use.tests
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 0 }
T{ ##peek f V int-regs 2 D 0 }
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 0 }
T{ ##peek f 2 D 0 }
} 1 test-bb
V{
T{ ##replace f V int-regs 2 D 0 }
T{ ##replace f 2 D 0 }
} 2 test-bb
1 get 2 get 1vector >>successors drop
1 2 edge
V{
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f 0 D 0 }
} 3 test-bb
2 get 3 get 1vector >>successors drop
2 3 edge
V{ } 4 test-bb
V{ } 5 test-bb
3 get 4 get 5 get V{ } 2sequence >>successors drop
V int-regs 2
2 get V int-regs 0 2array
3 get V int-regs 1 2array
2array \ ##phi new-insn 1vector
6 test-bb
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
3 { 4 5 } edges
V{
T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
} 6 test-bb
4 6 edge
5 6 edge
cfg new 1 get >>entry 0 set
[ ] [ 0 get compute-def-use ] unit-test
[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test

3
basis/compiler/cfg/def-use/def-use.factor
View File

@ -92,6 +92,3 @@ SYMBOLS: defs insns uses ;
] each
] each-basic-block
use [ keys ] assoc-map uses set ;
: compute-def-use ( cfg -- )
[ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;

5
basis/compiler/cfg/dominance/dominance-tests.factor
View File

@ -1,12 +1,11 @@
IN: compiler.cfg.dominance.tests
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
compiler.cfg.predecessors ;
IN: compiler.cfg.dominance.tests
: test-dominance ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-dominance ;
needs-dominance drop ;
! Example with no back edges
V{ } 0 test-bb

10
basis/compiler/cfg/dominance/dominance.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
compiler.cfg.rpo ;
compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dominance
! Reference:
@ -83,10 +83,14 @@ PRIVATE>
H{ } clone maxpreorder set
[ 0 ] dip entry>> (compute-dfs) drop ;
: compute-dominance ( cfg -- cfg' )
[ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
PRIVATE>
: compute-dominance ( cfg -- )
[ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
: needs-dominance ( cfg -- cfg' )
needs-predecessors
dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
: dominates? ( bb1 bb2 -- ? )
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;

17
basis/compiler/cfg/empty-blocks/empty-blocks.factor
View File

@ -1,9 +1,12 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
USING: kernel accessors sequences namespaces combinators
combinators.short-circuit classes vectors compiler.cfg
compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.empty-blocks
<PRIVATE
: update-predecessor ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
@ -22,8 +25,11 @@ IN: compiler.cfg.empty-blocks
] with map
] change-predecessors drop ;
SYMBOL: changed?
: delete-basic-block ( bb -- )
[ update-predecessor ] [ update-successor ] bi ;
[ update-predecessor ] [ update-successor ] bi
changed? on ;
: delete-basic-block? ( bb -- ? )
{
@ -33,6 +39,9 @@ IN: compiler.cfg.empty-blocks
[ instructions>> first ##branch? ]
} 1&& ;
PRIVATE>
: delete-empty-blocks ( cfg -- cfg' )
changed? off
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
cfg-changed ;
changed? get [ cfg-changed ] when ;

8
basis/compiler/cfg/gc-checks/gc-checks-tests.factor
View File

@ -1,22 +1,22 @@
IN: compiler.cfg.gc-checks.tests
USING: compiler.cfg.gc-checks compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
cfg new 0 get >>entry
compute-predecessors
insert-gc-checks
drop ;
V{
T{ ##inc-d f 3 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f 0 D 1 }
} 0 test-bb
V{
T{ ##box-float f V int-regs 0 V int-regs 1 }
T{ ##box-float f 0 1 }
} 1 test-bb
0 1 edge

9
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -1,13 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs fry
cpu.architecture
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
! Garbage collection check insertion. This pass runs after representation
! selection, so it must keep track of representations.
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
@ -16,7 +19,9 @@ IN: compiler.cfg.gc-checks
: insert-gc-check ( bb -- )
dup '[
i i f _ uninitialized-locs \ ##gc new-insn
int-rep next-vreg-rep
int-rep next-vreg-rep
f f _ uninitialized-locs \ ##gc new-insn
prefix
] change-instructions drop ;

135
basis/compiler/cfg/hats/hats.factor
View File

@ -1,83 +1,74 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel layouts math namespaces
USING: accessors arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
: i ( -- vreg ) int-regs next-vreg ; inline
: ^^i ( -- vreg vreg ) i dup ; inline
: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
: ^^r ( -- vreg vreg ) next-vreg dup ; inline
: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
: d ( -- vreg ) double-float-regs next-vreg ; inline
: ^^d ( -- vreg vreg ) d dup ; inline
: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^r2 ##and ; inline
: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^r1 ##not ; inline
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline

42
basis/compiler/cfg/instructions/instructions.factor
View File

@ -112,8 +112,7 @@ INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ;
INSN: ##copy < ##unary rep ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
@ -190,7 +189,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
@ -219,14 +218,13 @@ INSN: _fixnum-mul < _fixnum-overflow ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
INSN: _spill src rep n ;
INSN: _reload dst rep n ;
INSN: _spill-area-size n ;
! Instructions that use vregs
UNION: vreg-insn
@ -252,6 +250,34 @@ UNION: kill-vreg-insn
##alien-indirect
##alien-callback ;
! Instructions that output floats
UNION: output-float-insn
##add-float
##sub-float
##mul-float
##div-float
##integer>float
##unbox-float
##alien-float
##alien-double ;
! Instructions that take floats as inputs
UNION: input-float-insn
##add-float
##sub-float
##mul-float
##div-float
##float>integer
##box-float
##set-alien-float
##set-alien-double
##compare-float
##compare-float-branch ;
! Smackdown
INTERSECTION: ##unary-float ##unary input-float-insn ;
INTERSECTION: ##binary-float ##binary input-float-insn ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn

16
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -53,7 +53,7 @@ IN: compiler.cfg.intrinsics.alien
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
'[ ds-pop ^^unbox-float @ ]
'[ ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
@ -90,18 +90,18 @@ IN: compiler.cfg.intrinsics.alien
: emit-alien-cell-setter ( node -- )
[ ##set-alien-cell ] inline-alien-cell-setter ;
: emit-alien-float-getter ( node reg-class -- )
: emit-alien-float-getter ( node rep -- )
'[
_ {
{ single-float-regs [ ^^alien-float ] }
{ double-float-regs [ ^^alien-double ] }
} case ^^box-float
{ single-float-rep [ ^^alien-float ] }
{ double-float-rep [ ^^alien-double ] }
} case
] inline-alien-getter ;
: emit-alien-float-setter ( node reg-class -- )
: emit-alien-float-setter ( node rep -- )
'[
_ {
{ single-float-regs [ ##set-alien-float ] }
{ double-float-regs [ ##set-alien-double ] }
{ single-float-rep [ ##set-alien-float ] }
{ double-float-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;

4
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -8,11 +8,11 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
'[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
'[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
[ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
[ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )

12
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -1,19 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
ds-push ; inline
[ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
ds-push ; inline
[ 2inputs ] dip ^^compare-float ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
ds-pop ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
ds-pop ^^untag-fixnum ^^integer>float ds-push ;

8
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -153,8 +153,8 @@ IN: compiler.cfg.intrinsics
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} case ;

10
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
USING: layouts namespaces kernel accessors sequences classes.algebra
compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
@ -45,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if
[ drop ] [ next-vreg next-vreg ##write-barrier ] if
] [ drop emit-primitive ] if ;
: emit-string-nth ( -- )
@ -53,4 +53,4 @@ IN: compiler.cfg.intrinsics.slots
: emit-set-string-nth-fast ( -- )
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
swap i ##set-string-nth-fast ;
swap next-vreg ##set-string-nth-fast ;

13
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -3,7 +3,6 @@
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
@ -29,13 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
second 0 = ; inline
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ drop assign-blocked-register ]
} cond
] if ;
dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ drop assign-blocked-register ]
} cond ;
: handle-interval ( live-interval -- )
[

35
basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
View File

@ -1,35 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces assocs fry
combinators.short-circuit
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: avoids-inactive-intervals? ( live-interval -- ? )
dup vreg>> inactive-intervals-for
[ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? )
{
[ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
[ avoids-inactive-intervals? ]
} 1&& ;
: reuse-spill-slot ( old new -- )
[ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
: reuse-register ( old new -- )
reg>> >>reg drop ;
: (coalesce) ( old new -- )
[ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;

2
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -45,7 +45,7 @@ ERROR: splitting-atomic-interval ;
f >>spill-to ; inline
: split-after ( after -- after' )
f >>copy-from f >>reg f >>reload-from ; inline
f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split

21
basis/compiler/cfg/linear-scan/allocation/state/state.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors
compiler.cfg compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
@ -26,7 +27,7 @@ SYMBOL: registers
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
rep-of reg-class-of active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
@ -41,7 +42,7 @@ SYMBOL: active-intervals
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
reg-class>> inactive-intervals get at ;
rep-of reg-class-of inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
@ -112,22 +113,18 @@ SYMBOL: unhandled-intervals
[ dup start>> unhandled-intervals get heap-push ]
bi ;
CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
! Mapping from register classes to spill counts
SYMBOL: spill-counts
: next-spill-slot ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
: next-spill-slot ( rep -- n )
rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
! Mapping from vregs to spill slots
SYMBOL: spill-slots
: assign-spill-slot ( vreg -- n )
spill-slots get [ reg-class>> next-spill-slot ] cache ;
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
@ -135,7 +132,7 @@ SYMBOL: spill-slots
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
[ 0 ] reg-class-assoc spill-counts set
cfg get 0 >>spill-area-size drop
H{ } clone spill-slots set
-1 progress set ;
@ -145,7 +142,7 @@ SYMBOL: spill-slots
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;

41
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators sets locals
fry make combinators sets locals arrays
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.renaming.functor
compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
@ -52,7 +52,7 @@ SYMBOL: register-live-outs
init-unhandled ;
: insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
[ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
@ -72,7 +72,7 @@ SYMBOL: register-live-outs
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
[ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
@ -103,11 +103,36 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
! TODO: needs tagged-rep
: trace-on-gc ( assoc -- assoc' )
! When a GC occurs, virtual registers which contain tagged data
! are traced by the GC. Outputs a sequence physical registers.
[ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
: spill-on-gc? ( vreg reg -- ? )
[ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
: spill-on-gc ( assoc -- assoc' )
! When a GC occurs, virtual registers which contain untagged data,
! and are stored in physical registers, are saved to their spill
! slots. Outputs sequence of triples:
! - physical register
! - spill slot
! - representation
[
[
2dup spill-on-gc?
[ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
M: ##gc assign-registers-in-insn
! This works because ##gc is always the first instruction
! in a block.
! Since ##gc is always the first instruction in a block, the set of
! values live at the ##gc is just live-in.
dup call-next-method
basic-block get register-live-ins get at >>live-values
basic-block get register-live-ins get at
[ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
drop ;
M: insn assign-registers-in-insn drop ;
@ -156,4 +181,4 @@ ERROR: bad-vreg vreg ;
: assign-registers ( live-intervals cfg -- )
[ init-assignment ] dip
[ assign-registers-in-block ] each-basic-block ;
linearization-order [ assign-registers-in-block ] each ;

3
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -18,9 +18,8 @@ IN: compiler.cfg.linear-scan.debugger
: interval-picture ( interval -- str )
[ uses>> picture ]
[ copy-from>> unparse ]
[ vreg>> unparse ]
tri 3array ;
bi 2array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;

1700
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

File diff suppressed because it is too large Load Diff

7
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -5,6 +5,7 @@ cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
@ -37,8 +38,4 @@ IN: compiler.cfg.linear-scan
cfg check-numbering ;
: linear-scan ( cfg -- cfg' )
[
dup machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed
] with-scope ;
dup machine-registers (linear-scan) ;

17
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
combinators binary-search compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
@ -13,8 +13,7 @@ C: <live-range> live-range
TUPLE: live-interval
vreg
reg spill-to reload-from
start end ranges uses
copy-from ;
start end ranges uses ;
GENERIC: covers? ( insn# obj -- ? )
@ -102,15 +101,6 @@ M: vreg-insn compute-live-intervals*
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
: handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
@ -147,7 +137,8 @@ ERROR: bad-live-interval live-interval ;
: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
post-order [ compute-live-intervals-step ] each
linearization-order <reversed>
[ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )

9
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces
compiler.cfg.rpo ;
compiler.cfg.linearization.order ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
[ 0 ] dip [
linearization-order 0 [
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
] each-basic-block drop ;
] reduce drop ;
SYMBOL: check-numbering?
@ -20,4 +20,5 @@ ERROR: bad-numbering bb ;
[ drop ] [ bad-numbering ] if ;
: check-numbering ( cfg -- )
check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
check-numbering? get
[ linearization-order [ check-block-numbering ] each ] [ drop ] if ;

36
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -1,65 +1,67 @@
IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
accessors
compiler.cfg
compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve.tests
[
{
{ { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
{ { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
}
] [
[
0 <spill-slot> 1 int-regs add-mapping
0 <spill-slot> 1 int-rep add-mapping
] { } make
] unit-test
[
{
T{ _reload { dst 1 } { class int-regs } { n 0 } }
T{ _reload { dst 1 } { rep int-rep } { n 0 } }
}
] [
[
{ T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn
{ T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
] { } make
] unit-test
[
{
T{ _spill { src 1 } { class int-regs } { n 0 } }
T{ _spill { src 1 } { rep int-rep } { n 0 } }
}
] [
[
{ 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn
{ 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
] { } make
] unit-test
[
{
T{ _copy { src 1 } { dst 2 } { class int-regs } }
T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
}
] [
[
{ 1 int-regs } { 2 int-regs } >insn
{ 1 int-rep } { 2 int-rep } >insn
] { } make
] unit-test
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
cfg new 8 >>spill-area-size cfg set
H{ } clone spill-temps set
[
t
] [
{ { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
{ { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions {
{
T{ _spill { src 0 } { class int-regs } { n 10 } }
T{ _copy { dst 0 } { src 1 } { class int-regs } }
T{ _reload { dst 1 } { class int-regs } { n 10 } }
T{ _spill { src 0 } { rep int-rep } { n 8 } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
T{ _reload { dst 1 } { rep int-rep } { n 8 } }
}
{
T{ _spill { src 1 } { class int-regs } { n 10 } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
T{ _spill { src 1 } { rep int-rep } { n 8 } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
T{ _reload { dst 0 } { rep int-rep } { n 8 } }
}
} member?
] unit-test

17
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -3,10 +3,13 @@
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.utilities
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.parallel-copy
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.allocation.state ;
@ -14,16 +17,16 @@ IN: compiler.cfg.linear-scan.resolve
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
: spill-temp ( rep -- n )
spill-temps get [ next-spill-slot ] cache ;
: add-mapping ( from to reg-class -- )
: add-mapping ( from to rep -- )
'[ _ 2array ] bi@ 2array , ;
:: resolve-value-data-flow ( bb to vreg -- )
vreg bb vreg-at-end
vreg to vreg-at-start
2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
dup live-in dup assoc-empty? [ 3drop f ] [
@ -43,7 +46,7 @@ SYMBOL: spill-temps
drop [ first2 ] [ second spill-temp ] bi _spill ;
: register->register ( from to -- )
swap [ first ] [ first2 ] bi* _copy ;
swap [ first ] [ first2 ] bi* ##copy ;
SYMBOL: temp
@ -62,8 +65,8 @@ SYMBOL: temp
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
mapping-instructions <simple-block>
insert-basic-block
mapping-instructions <simple-block> insert-basic-block
cfg get cfg-changed drop
] if ;
: resolve-edge-data-flow ( bb to -- )
@ -73,5 +76,7 @@ SYMBOL: temp
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
needs-predecessors
H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;

4
basis/compiler/cfg/linearization/linearization-tests.factor
View File

@ -1,4 +0,0 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;

58
basis/compiler/cfg/linearization/linearization.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
combinators assocs arrays locals cpu.architecture
combinators assocs arrays locals layouts hashtables
cpu.architecture
compiler.cfg
compiler.cfg.comparisons
compiler.cfg.stack-frame
@ -10,6 +11,14 @@ compiler.cfg.utilities
compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization
<PRIVATE
SYMBOL: numbers
: block-number ( bb -- n ) numbers get at ;
: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
@ -70,55 +79,32 @@ M: ##dispatch linearize-insn
[ successors>> [ block-number _dispatch-label ] each ]
bi* ;
: (compute-gc-roots) ( n live-values -- n )
[
[ nip 2array , ]
[ drop reg-class>> reg-size + ]
3bi
] assoc-each ;
: oop-values ( regs -- regs' )
[ drop reg-class>> int-regs eq? ] assoc-filter ;
: data-values ( regs -- regs' )
[ drop reg-class>> double-float-regs eq? ] assoc-filter ;
: compute-gc-roots ( live-values -- alist )
[
[ 0 ] dip
! we put float registers last; the GC doesn't actually scan them
[ oop-values (compute-gc-roots) ]
[ data-values (compute-gc-roots) ] bi
drop
] { } make ;
: count-gc-roots ( live-values -- n )
! Size of GC root area, minus the float registers
oop-values assoc-size ;
: gc-root-offsets ( registers -- alist )
! Outputs a sequence of { offset register/spill-slot } pairs
[ length iota [ cell * ] map ] keep zip ;
M: ##gc linearize-insn
nip
{
[ temp1>> ]
[ temp2>> ]
[
live-values>>
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
tri
]
[ data-values>> ]
[ tagged-values>> gc-root-offsets ]
[ uninitialized-locs>> ]
} cleave
_gc ;
: linearize-basic-blocks ( cfg -- insns )
[
[ linearization-order [ linearize-basic-block ] each ]
[ spill-counts>> _spill-counts ]
bi
[
linearization-order
[ number-blocks ]
[ [ linearize-basic-block ] each ] bi
] [ spill-area-size>> _spill-area-size ] bi
] { } make ;
PRIVATE>
: flatten-cfg ( cfg -- mr )
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;

46
basis/compiler/cfg/linearization/order/order.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel make
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
fry math sets compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg.loop-detection ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
<PRIVATE
SYMBOLS: work-list loop-heads visited numbers next-number ;
SYMBOLS: work-list loop-heads visited ;
: visited? ( bb -- ? ) visited get key? ;
@ -18,6 +19,11 @@ SYMBOLS: work-list loop-heads visited numbers next-number ;
work-list get push-back
] if ;
: init-linearization-order ( cfg -- )
<dlist> work-list set
H{ } clone visited set
entry>> add-to-work-list ;
: (find-alternate-loop-head) ( bb -- bb' )
dup {
[ predecessor visited? not ]
@ -46,28 +52,26 @@ SYMBOLS: work-list loop-heads visited numbers next-number ;
add-to-work-list
] [ drop ] if ;
: assign-number ( bb -- )
next-number [ get ] [ inc ] bi swap numbers get set-at ;
: sorted-successors ( bb -- seq )
successors>> <reversed> [ loop-nesting-at ] sort-with ;
: process-block ( bb -- )
{
[ , ]
[ assign-number ]
[ visited get conjoin ]
[ successors>> <reversed> [ process-successor ] each ]
} cleave ;
[ , ]
[ visited get conjoin ]
[ sorted-successors [ process-successor ] each ]
tri ;
: (linearization-order) ( cfg -- bbs )
init-linearization-order
[ work-list get [ process-block ] slurp-deque ] { } make ;
PRIVATE>
: linearization-order ( cfg -- bbs )
! We call 'post-order drop' to ensure blocks receive their
! RPO numbers.
<dlist> work-list set
H{ } clone visited set
H{ } clone numbers set
0 next-number set
[ post-order drop ]
[ entry>> add-to-work-list ] bi
[ work-list get [ process-block ] slurp-deque ] { } make ;
needs-post-order needs-loops
: block-number ( bb -- n ) numbers get at ;
dup linear-order>> [ ] [
dup (linearization-order)
>>linear-order linear-order>>
] ?if ;

25
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -6,26 +6,25 @@ IN: compiler.cfg.liveness.tests
: test-liveness ( -- )
cfg new 1 get >>entry
compute-predecessors
compute-live-sets ;
! Sanity check...
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f 0 D 0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
T{ ##peek f 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##replace f V int-regs 2 D 0 }
T{ ##replace f 2 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
T{ ##replace f 3 D 0 }
T{ ##return }
} 3 test-bb
@ -35,9 +34,9 @@ test-liveness
[
H{
{ V int-regs 1 V int-regs 1 }
{ V int-regs 2 V int-regs 2 }
{ V int-regs 3 V int-regs 3 }
{ 1 1 }
{ 2 2 }
{ 3 3 }
}
]
[ 1 get live-in ]
@ -46,12 +45,12 @@ unit-test
! Tricky case; defs must be killed before uses
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
T{ ##add-imm f V int-regs 0 V int-regs 0 10 }
T{ ##add-imm f 0 0 10 }
T{ ##return }
} 2 test-bb
@ -59,4 +58,4 @@ V{
test-liveness
[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test
[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test

2
basis/compiler/cfg/liveness/liveness.factor
View File

@ -28,4 +28,4 @@ M: live-analysis transfer-set
drop instructions>> transfer-liveness ;
M: live-analysis join-sets
drop assoc-combine ;
2drop assoc-combine ;

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