Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
2c533472f8
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: biassocs assocs namespaces tools.test hashtables kernel ;
|
||||
IN: biassocs.tests
|
||||
USING: biassocs assocs namespaces tools.test ;
|
||||
|
||||
<bihash> "h" set
|
||||
|
||||
|
|
@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set
|
|||
[ "A" ] [ "a" "b" get at ] unit-test
|
||||
|
||||
[ "a" ] [ "A" "b" get value-at ] unit-test
|
||||
|
||||
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
|
||||
|
||||
[ ] [ "h" get clone "g" set ] unit-test
|
||||
|
||||
[ ] [ 3 4 "g" get set-at ] unit-test
|
||||
|
||||
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test
|
||||
|
|
|
|||
|
|
@ -44,3 +44,6 @@ INSTANCE: biassoc assoc
|
|||
|
||||
: >biassoc ( assoc -- biassoc )
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
|
||||
M: biassoc clone
|
||||
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -44,33 +44,33 @@ PRIVATE>
|
|||
: <bit-array> ( n -- bit-array )
|
||||
dup bits>bytes <byte-array> bit-array boa ; inline
|
||||
|
||||
M: bit-array length length>> ;
|
||||
M: bit-array length length>> ; inline
|
||||
|
||||
M: bit-array nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
|
||||
|
||||
M: bit-array set-nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi*
|
||||
[ byte/bit set-bit ] 2keep
|
||||
swap n>byte set-alien-unsigned-1 ;
|
||||
swap n>byte set-alien-unsigned-1 ; inline
|
||||
|
||||
GENERIC: clear-bits ( bit-array -- )
|
||||
|
||||
M: bit-array clear-bits 0 (set-bits) ;
|
||||
M: bit-array clear-bits 0 (set-bits) ; inline
|
||||
|
||||
GENERIC: set-bits ( bit-array -- )
|
||||
|
||||
M: bit-array set-bits -1 (set-bits) ;
|
||||
M: bit-array set-bits -1 (set-bits) ; inline
|
||||
|
||||
M: bit-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
|
||||
|
||||
: >bit-array ( seq -- bit-array )
|
||||
T{ bit-array f 0 B{ } } clone-like ; inline
|
||||
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
|
||||
|
||||
M: bit-array new-sequence drop <bit-array> ;
|
||||
M: bit-array new-sequence drop <bit-array> ; inline
|
||||
|
||||
M: bit-array equal?
|
||||
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
|
||||
|
|
@ -81,7 +81,7 @@ M: bit-array resize
|
|||
resize-byte-array
|
||||
] 2bi
|
||||
bit-array boa
|
||||
dup clean-up ;
|
||||
dup clean-up ; inline
|
||||
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@ gc
|
|||
: compile-unoptimized ( words -- )
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
"debug-compiler" get [
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
||||
|
|
@ -74,7 +76,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
+ 1+ 1- 2/ < <= > >= shift
|
||||
+ 2/ < <= > >= shift
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
|
@ -115,3 +117,5 @@ nl
|
|||
vocabs [ words compile-unoptimized "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
|
||||
] unless
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ IN: bootstrap.tools
|
|||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.deprecation"
|
||||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: boxes.tests
|
||||
USING: boxes namespaces tools.test accessors ;
|
||||
IN: boxes.tests
|
||||
|
||||
[ ] [ <box> "b" set ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -8,4 +8,3 @@ SYNTAX: HEX{
|
|||
[ blank? not ] filter
|
||||
2 group [ hex> ] B{ } map-as
|
||||
parsed ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
IN: cairo.tests
|
||||
USING: cairo tools.test math.rectangles accessors ;
|
||||
IN: cairo.tests
|
||||
|
||||
[ { 10 20 } ] [
|
||||
{ 10 20 } [
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ HELP: <date>
|
|||
} ;
|
||||
|
||||
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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,22 +34,22 @@ 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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
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
|
||||
dup terminated?>> [ cannot-determine-arity ] when
|
||||
effect-height neg 1 + ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
IN: compiler.cfg.alias-analysis.tests
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
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
|
||||
compiler.cfg arrays locals byte-arrays kernel.private math
|
||||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
strings.private ;
|
||||
strings.private accessors compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
: unit-test-cfg ( quot -- )
|
||||
|
|
@ -157,3 +157,26 @@ strings.private ;
|
|||
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
|
||||
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
|
||||
] each
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
[ test-mr [ instructions>> ] map ] dip
|
||||
'[ _ any? ] any? ; inline
|
||||
|
||||
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
|
@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities
|
|||
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,11 @@ 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 ;
|
||||
! Only consider initialized sets.
|
||||
bb dfa predecessors
|
||||
[ out-sets key? ] filter
|
||||
[ out-sets at ] map
|
||||
bb dfa join-sets ;
|
||||
|
||||
:: update-in-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb out-sets dfa compute-in-set
|
||||
|
|
@ -56,7 +60,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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ compiler.cfg
|
|||
compiler.cfg.debugger
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.cfg.def-use.tests
|
||||
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
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
|
||||
|
||||
[
|
||||
{
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ SYMBOL: temp
|
|||
|
||||
: perform-mappings ( bb to mappings -- )
|
||||
dup empty? [ 3drop ] [
|
||||
mapping-instructions <simple-block> insert-basic-block
|
||||
mapping-instructions insert-simple-basic-block
|
||||
cfg get cfg-changed drop
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
IN: compiler.cfg.linearization.tests
|
||||
USING: compiler.cfg.linearization tools.test ;
|
||||
|
||||
|
||||
|
|
@ -28,4 +28,4 @@ M: live-analysis transfer-set
|
|||
drop instructions>> transfer-liveness ;
|
||||
|
||||
M: live-analysis join-sets
|
||||
drop assoc-combine ;
|
||||
2drop assoc-combine ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: compiler.cfg.loop-detection.tests
|
||||
USING: compiler.cfg compiler.cfg.loop-detection
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.debugger
|
||||
tools.test kernel namespaces accessors ;
|
||||
IN: compiler.cfg.loop-detection.tests
|
||||
|
||||
V{ } 0 test-bb
|
||||
V{ } 1 test-bb
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
|
|||
|
||||
TUPLE: natural-loop header index ends blocks ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: loops
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <natural-loop> ( header index -- loop )
|
||||
H{ } clone H{ } clone natural-loop boa ;
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
|
|||
! computing anything.
|
||||
2dup [ kill-block? ] both? [ 2drop ] [
|
||||
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
|
||||
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty
|
||||
[ 2drop ] [ insert-simple-basic-block ] if-empty
|
||||
] if ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live
|
|||
|
||||
M: live-analysis transfer-set drop transfer-peeked-locs ;
|
||||
|
||||
M: live-analysis join-sets drop assoc-combine ;
|
||||
M: live-analysis join-sets 2drop assoc-combine ;
|
||||
|
||||
! A stack location is available at a location if all paths from
|
||||
! the entry block to the location load the location into a
|
||||
|
|
|
|||
|
|
@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
|
||||
: peek-loc ( loc -- vreg )
|
||||
translate-local-loc
|
||||
dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
|
||||
dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
|
||||
dup replace-mapping get at
|
||||
[ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
|
||||
|
||||
: replace-loc ( vreg loc -- )
|
||||
translate-local-loc
|
||||
2dup loc>vreg =
|
||||
[ nip replace-mapping get delete-at ]
|
||||
[
|
||||
[ local-replace-set get conjoin ]
|
||||
[ replace-mapping get set-at ]
|
||||
bi
|
||||
] if ;
|
||||
translate-local-loc replace-mapping get set-at ;
|
||||
|
||||
: compute-local-kill-set ( -- assoc )
|
||||
basic-block get current-height get
|
||||
|
|
@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
|
||||
: begin-local-analysis ( -- )
|
||||
H{ } clone local-peek-set set
|
||||
H{ } clone local-replace-set set
|
||||
H{ } clone replace-mapping set
|
||||
current-height get
|
||||
[ 0 >>emit-d 0 >>emit-r drop ]
|
||||
[ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
|
||||
|
||||
: remove-redundant-replaces ( -- )
|
||||
replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
|
||||
[ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
|
||||
|
||||
: end-local-analysis ( -- )
|
||||
remove-redundant-replaces
|
||||
emit-changes
|
||||
basic-block get {
|
||||
[ [ local-peek-set get ] dip peek-sets get set-at ]
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: compiler.cfg.stacks.uninitialized.tests
|
||||
USING: compiler.cfg.stacks.uninitialized 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.stacks.uninitialized.tests
|
||||
|
||||
: test-uninitialized ( -- )
|
||||
cfg new 0 get >>entry
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
|
|||
drop [ prepare ] dip visit-block finish ;
|
||||
|
||||
M: uninitialized-analysis join-sets ( sets analysis -- pair )
|
||||
drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
|
||||
2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
|
||||
|
||||
: uninitialized-locs ( bb -- locs )
|
||||
uninitialized-in dup [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.cfg.two-operand.tests
|
||||
USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
|
||||
compiler.cfg.registers cpu.architecture namespaces tools.test ;
|
||||
IN: compiler.cfg.two-operand.tests
|
||||
|
||||
3 vreg-counter set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs combinators combinators.short-circuit
|
||||
cpu.architecture kernel layouts locals make math namespaces sequences
|
||||
sets vectors fry compiler.cfg compiler.cfg.instructions
|
||||
compiler.cfg.rpo ;
|
||||
compiler.cfg.rpo arrays ;
|
||||
IN: compiler.cfg.utilities
|
||||
|
||||
PREDICATE: kill-block < basic-block
|
||||
|
|
@ -37,16 +37,16 @@ SYMBOL: visited
|
|||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
:: insert-basic-block ( from to bb -- )
|
||||
bb from 1vector >>predecessors drop
|
||||
:: insert-basic-block ( froms to bb -- )
|
||||
bb froms V{ } like >>predecessors drop
|
||||
bb to 1vector >>successors drop
|
||||
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
|
||||
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
|
||||
to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
|
||||
froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
|
||||
|
||||
: add-instructions ( bb quot -- )
|
||||
[ instructions>> building ] dip '[
|
||||
building get pop
|
||||
@
|
||||
[ @ ] dip
|
||||
,
|
||||
] with-variable ; inline
|
||||
|
||||
|
|
@ -56,6 +56,9 @@ SYMBOL: visited
|
|||
\ ##branch new-insn over push
|
||||
>>instructions ;
|
||||
|
||||
: insert-simple-basic-block ( from to insns -- )
|
||||
[ 1vector ] 2dip <simple-block> insert-basic-block ;
|
||||
|
||||
: has-phis? ( bb -- ? )
|
||||
instructions>> first ##phi? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
@ -1,7 +1,16 @@
|
|||
USING: compiler.cfg.write-barrier compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
|
||||
arrays tools.test vectors compiler.cfg kernel accessors
|
||||
compiler.cfg.utilities ;
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs compiler.cfg
|
||||
compiler.cfg.alias-analysis compiler.cfg.block-joining
|
||||
compiler.cfg.branch-splitting compiler.cfg.copy-prop
|
||||
compiler.cfg.dce compiler.cfg.debugger
|
||||
compiler.cfg.instructions compiler.cfg.loop-detection
|
||||
compiler.cfg.registers compiler.cfg.ssa.construction
|
||||
compiler.cfg.tco compiler.cfg.useless-conditionals
|
||||
compiler.cfg.utilities compiler.cfg.value-numbering
|
||||
compiler.cfg.write-barrier cpu.architecture kernel
|
||||
kernel.private math namespaces sequences sequences.private
|
||||
tools.test vectors ;
|
||||
IN: compiler.cfg.write-barrier.tests
|
||||
|
||||
: test-write-barrier ( insns -- insns )
|
||||
|
|
@ -70,3 +79,112 @@ IN: compiler.cfg.write-barrier.tests
|
|||
T{ ##write-barrier f 19 30 3 }
|
||||
} test-write-barrier
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 1 test-bb
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 2 test-bb
|
||||
1 get 2 get 1vector >>successors drop
|
||||
cfg new 1 get >>entry 0 set
|
||||
|
||||
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} ] [ 1 get instructions>> ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
} ] [ 2 get instructions>> ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
} 1 test-bb
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 2 test-bb
|
||||
1 get 2 get 1vector >>successors drop
|
||||
cfg new 1 get >>entry 0 set
|
||||
|
||||
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
|
||||
[ V{
|
||||
T{ ##allot f 1 }
|
||||
} ] [ 1 get instructions>> ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
} ] [ 2 get instructions>> ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 1 test-bb
|
||||
V{
|
||||
T{ ##allot }
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 2 test-bb
|
||||
1 get 2 get 1vector >>successors drop
|
||||
cfg new 1 get >>entry 0 set
|
||||
|
||||
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} ] [ 1 get instructions>> ] unit-test
|
||||
[ V{
|
||||
T{ ##allot }
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} ] [ 2 get instructions>> ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 1 test-bb
|
||||
V{
|
||||
T{ ##allot }
|
||||
} 2 test-bb
|
||||
1 get 2 get 1vector >>successors drop
|
||||
V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} 3 test-bb
|
||||
2 get 3 get 1vector >>successors drop
|
||||
cfg new 1 get >>entry 0 set
|
||||
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} ] [ 1 get instructions>> ] unit-test
|
||||
[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
|
||||
[ V{
|
||||
T{ ##set-slot-imm f 2 1 3 4 }
|
||||
T{ ##write-barrier f 1 2 3 }
|
||||
} ] [ 3 get instructions>> ] unit-test
|
||||
|
||||
: reverse-here' ( seq -- )
|
||||
{ array } declare
|
||||
[ length 2/ iota ] [ length ] [ ] tri
|
||||
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
|
||||
|
||||
: write-barrier-stats ( word -- cfg )
|
||||
test-cfg first [
|
||||
optimize-tail-calls
|
||||
delete-useless-conditionals
|
||||
split-branches
|
||||
join-blocks
|
||||
construct-ssa
|
||||
alias-analysis
|
||||
value-numbering
|
||||
copy-propagation
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
] with-cfg
|
||||
post-order>> write-barriers
|
||||
[ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
|
||||
|
||||
[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,16 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces assocs sets sequences
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
fry combinators.short-circuit locals make arrays
|
||||
compiler.cfg
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.loop-detection
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.dataflow-analysis
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.write-barrier
|
||||
|
||||
! Eliminate redundant write barrier hits.
|
||||
|
|
@ -19,21 +28,112 @@ M: ##allot eliminate-write-barrier
|
|||
dst>> safe get conjoin t ;
|
||||
|
||||
M: ##write-barrier eliminate-write-barrier
|
||||
src>> dup [ safe get key? not ] [ mutated get key? ] bi and
|
||||
src>> dup safe get key? not
|
||||
[ safe get conjoin t ] [ drop f ] if ;
|
||||
|
||||
M: ##set-slot eliminate-write-barrier
|
||||
obj>> mutated get conjoin t ;
|
||||
|
||||
M: ##set-slot-imm eliminate-write-barrier
|
||||
obj>> mutated get conjoin t ;
|
||||
|
||||
M: insn eliminate-write-barrier drop t ;
|
||||
|
||||
! This doesn't actually benefit from being a dataflow analysis
|
||||
! might as well be dominator-based
|
||||
! Dealing with phi functions would help, though
|
||||
FORWARD-ANALYSIS: safe
|
||||
|
||||
: has-allocation? ( bb -- ? )
|
||||
instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
|
||||
|
||||
M: safe-analysis transfer-set
|
||||
drop [ H{ } assoc-clone-like safe set ] dip
|
||||
instructions>> [
|
||||
eliminate-write-barrier drop
|
||||
] each safe get ;
|
||||
|
||||
M: safe-analysis join-sets
|
||||
drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
|
||||
|
||||
: write-barriers-step ( bb -- )
|
||||
H{ } clone safe set
|
||||
H{ } clone mutated set
|
||||
dup safe-in H{ } assoc-clone-like safe set
|
||||
instructions>> [ eliminate-write-barrier ] filter-here ;
|
||||
|
||||
GENERIC: remove-dead-barrier ( insn -- ? )
|
||||
|
||||
M: ##write-barrier remove-dead-barrier
|
||||
src>> mutated get key? ;
|
||||
|
||||
M: ##set-slot remove-dead-barrier
|
||||
obj>> mutated get conjoin t ;
|
||||
|
||||
M: ##set-slot-imm remove-dead-barrier
|
||||
obj>> mutated get conjoin t ;
|
||||
|
||||
M: insn remove-dead-barrier drop t ;
|
||||
|
||||
: remove-dead-barriers ( bb -- )
|
||||
H{ } clone mutated set
|
||||
instructions>> [ remove-dead-barrier ] filter-here ;
|
||||
|
||||
! Availability of slot
|
||||
! Anticipation of this and set-slot would help too, maybe later
|
||||
FORWARD-ANALYSIS: slot
|
||||
|
||||
UNION: access ##read ##write ;
|
||||
|
||||
M: slot-analysis transfer-set
|
||||
drop [ H{ } assoc-clone-like ] dip
|
||||
instructions>> over '[
|
||||
dup access? [
|
||||
obj>> _ conjoin
|
||||
] [ drop ] if
|
||||
] each ;
|
||||
|
||||
: slot-available? ( vreg bb -- ? )
|
||||
slot-in key? ;
|
||||
|
||||
: make-barriers ( vregs -- bb )
|
||||
[ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
|
||||
|
||||
: emit-barriers ( vregs loop -- )
|
||||
swap [
|
||||
[ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
|
||||
[ header>> ] bi
|
||||
] [ make-barriers ] bi*
|
||||
insert-basic-block ;
|
||||
|
||||
: write-barriers ( bbs -- bb=>barriers )
|
||||
[
|
||||
dup instructions>>
|
||||
[ ##write-barrier? ] filter
|
||||
[ src>> ] map
|
||||
] { } map>assoc
|
||||
[ nip empty? not ] assoc-filter ;
|
||||
|
||||
: filter-dominant ( bb=>barriers bbs -- barriers )
|
||||
'[ drop _ [ dominates? ] with all? ] assoc-filter
|
||||
values concat prune ;
|
||||
|
||||
: dominant-write-barriers ( loop -- vregs )
|
||||
[ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
|
||||
|
||||
: safe-loops ( -- loops )
|
||||
loops get values
|
||||
[ blocks>> keys [ has-allocation? not ] all? ] filter ;
|
||||
|
||||
:: insert-extra-barriers ( cfg -- )
|
||||
safe-loops [| loop |
|
||||
cfg needs-dominance needs-predecessors drop
|
||||
loop dominant-write-barriers
|
||||
loop header>> '[ _ slot-available? ] filter
|
||||
[ loop emit-barriers cfg cfg-changed drop ] unless-empty
|
||||
] each ;
|
||||
|
||||
: contains-write-barrier? ( cfg -- ? )
|
||||
post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
|
||||
|
||||
: eliminate-write-barriers ( cfg -- cfg' )
|
||||
dup [ write-barriers-step ] each-basic-block ;
|
||||
dup contains-write-barrier? [
|
||||
needs-loops
|
||||
dup [ remove-dead-barriers ] each-basic-block
|
||||
dup compute-slot-sets
|
||||
dup insert-extra-barriers
|
||||
dup compute-safe-sets
|
||||
dup [ write-barriers-step ] each-basic-block
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.codegen.tests
|
||||
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
|
||||
compiler.constants ;
|
||||
IN: compiler.codegen.tests
|
||||
|
||||
[ ] [ [ ] with-fixup drop ] unit-test
|
||||
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
|||
} cond ;
|
||||
|
||||
: optimize? ( word -- ? )
|
||||
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
|
||||
single-generic? not ;
|
||||
|
||||
: contains-breakpoints? ( -- ? )
|
||||
dependencies get keys [ "break?" word-prop ] any? ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.call-effect
|
||||
USING: tools.test combinators generic.single sequences kernel ;
|
||||
IN: compiler.tests.call-effect
|
||||
|
||||
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tests.float
|
||||
USING: compiler.units compiler kernel kernel.private memory math
|
||||
math.private tools.test math.floats.private ;
|
||||
IN: compiler.tests.float
|
||||
|
||||
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
|
||||
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.generic
|
||||
USING: tools.test math kernel compiler.units definitions ;
|
||||
IN: compiler.tests.generic
|
||||
|
||||
GENERIC: bad ( -- )
|
||||
M: integer bad ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
|
|||
quotations classes classes.algebra classes.tuple.private
|
||||
continuations growable namespaces hints alien.accessors
|
||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||
compiler definitions ;
|
||||
compiler definitions generic.single ;
|
||||
IN: compiler.tests.optimizer
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
|
|
@ -423,3 +423,6 @@ M: object bad-dispatch-position-test* ;
|
|||
\ bad-dispatch-position-test* forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Not sure if I want to fix this...
|
||||
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.peg-regression-2
|
||||
USING: peg.ebnf strings tools.test ;
|
||||
IN: compiler.tests.peg-regression-2
|
||||
|
||||
GENERIC: <times> ( times -- term' )
|
||||
M: string <times> ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.pic-problem-1
|
||||
USING: kernel sequences prettyprint memory tools.test ;
|
||||
IN: compiler.tests.pic-problem-1
|
||||
|
||||
TUPLE: x ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tests.redefine0
|
||||
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
|
||||
namespaces macros assocs ;
|
||||
IN: compiler.tests.redefine0
|
||||
|
||||
! Test ripple-up behavior
|
||||
: test-1 ( -- a ) 3 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tests.redefine16
|
||||
USING: eval tools.test definitions words compiler.units
|
||||
quotations stack-checker ;
|
||||
IN: compiler.tests.redefine16
|
||||
|
||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tests.redefine17
|
||||
USING: tools.test classes.mixin compiler.units arrays kernel.private
|
||||
strings sequences vocabs definitions kernel ;
|
||||
IN: compiler.tests.redefine17
|
||||
|
||||
<< "compiler.tests.redefine17" words forget-all >>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.tests.redefine2
|
||||
USING: compiler compiler.units tools.test math parser kernel
|
||||
sequences sequences.private classes.mixin generic definitions
|
||||
arrays words assocs eval words.symbol ;
|
||||
IN: compiler.tests.redefine2
|
||||
|
||||
DEFER: redefine2-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
IN: compiler.tests.redefine3
|
||||
USING: accessors compiler compiler.units tools.test math parser
|
||||
kernel sequences sequences.private classes.mixin generic
|
||||
definitions arrays words assocs eval ;
|
||||
IN: compiler.tests.redefine3
|
||||
|
||||
GENERIC: sheeple ( obj -- x )
|
||||
|
||||
M: object sheeple drop "sheeple" ;
|
||||
M: object sheeple drop "sheeple" ; inline
|
||||
|
||||
MIXIN: empty-mixin
|
||||
|
||||
M: empty-mixin sheeple drop "wake up" ;
|
||||
M: empty-mixin sheeple drop "wake up" ; inline
|
||||
|
||||
: sheeple-test ( -- string ) { } sheeple ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.redefine4
|
||||
USING: io.streams.string kernel tools.test eval ;
|
||||
IN: compiler.tests.redefine4
|
||||
|
||||
: declaration-test-1 ( -- a ) 3 ; flushable
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.reload
|
||||
USE: vocabs.loader
|
||||
IN: compiler.tests.reload
|
||||
|
||||
! "parser" reload
|
||||
! "sequences" reload
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.tests.stack-trace
|
||||
USING: compiler tools.test namespaces sequences
|
||||
kernel.private kernel math continuations continuations.private
|
||||
words splitting grouping sorting accessors ;
|
||||
IN: compiler.tests.stack-trace
|
||||
|
||||
: symbolic-stack-trace ( -- newseq )
|
||||
error-continuation get call>> callstack>array
|
||||
|
|
@ -13,7 +13,7 @@ words splitting grouping sorting accessors ;
|
|||
[ baz ] [ 3 = ] must-fail-with
|
||||
[ t ] [
|
||||
symbolic-stack-trace
|
||||
[ word? ] filter
|
||||
2 head*
|
||||
{ baz bar foo } tail?
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tests.tuples
|
||||
USING: kernel tools.test compiler.units compiler ;
|
||||
IN: compiler.tests.tuples
|
||||
|
||||
TUPLE: color red green blue ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tree.builder.tests
|
||||
USING: compiler.tree.builder tools.test sequences kernel
|
||||
compiler.tree stack-checker stack-checker.errors ;
|
||||
IN: compiler.tree.builder.tests
|
||||
|
||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
IN: compiler.tree.checker.tests
|
||||
USING: compiler.tree.checker tools.test ;
|
||||
|
||||
|
||||
|
|
@ -1,4 +1,3 @@
|
|||
IN: compiler.tree.cleanup.tests
|
||||
USING: tools.test kernel.private kernel arrays sequences
|
||||
math.private math generic words quotations alien alien.c-types
|
||||
strings sbufs sequences.private slots.private combinators
|
||||
|
|
@ -17,6 +16,7 @@ compiler.tree.propagation
|
|||
compiler.tree.propagation.info
|
||||
compiler.tree.checker
|
||||
compiler.tree.debugger ;
|
||||
IN: compiler.tree.cleanup.tests
|
||||
|
||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
|
|
@ -41,13 +41,13 @@ compiler.tree.debugger ;
|
|||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
M: f mynot drop t ;
|
||||
M: f mynot drop t ; inline
|
||||
|
||||
M: object mynot drop f ;
|
||||
M: object mynot drop f ; inline
|
||||
|
||||
GENERIC: detect-f ( x -- y )
|
||||
|
||||
M: f detect-f ;
|
||||
M: f detect-f ; inline
|
||||
|
||||
[ t ] [
|
||||
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
|
||||
|
|
@ -55,9 +55,9 @@ M: f detect-f ;
|
|||
|
||||
GENERIC: xyz ( n -- n )
|
||||
|
||||
M: integer xyz ;
|
||||
M: integer xyz ; inline
|
||||
|
||||
M: object xyz ;
|
||||
M: object xyz ; inline
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare xyz ] \ xyz inlined?
|
||||
|
|
@ -115,10 +115,6 @@ M: object xyz ;
|
|||
[ { fixnum } declare [ ] times ] \ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ + inlined?
|
||||
] unit-test
|
||||
|
|
@ -172,19 +168,6 @@ M: object xyz ;
|
|||
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ [ ] times ] each ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
|
||||
\ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: annotate-entry-test-1 ( x -- )
|
||||
|
||||
M: fixnum annotate-entry-test-1 drop ;
|
||||
|
|
@ -305,10 +288,6 @@ cell-bits 32 = [
|
|||
] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
: rec ( a -- b )
|
||||
dup 0 > [ 1 - rec ] when ; inline recursive
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tree.combinators.tests
|
||||
USING: compiler.tree.combinators tools.test kernel ;
|
||||
IN: compiler.tree.combinators.tests
|
||||
|
||||
{ 1 0 } [ [ drop ] each-node ] must-infer-as
|
||||
{ 1 1 } [ [ ] map-nodes ] must-infer-as
|
||||
|
|
|
|||
|
|
@ -3,8 +3,7 @@
|
|||
USING: sequences namespaces kernel accessors assocs sets fry
|
||||
arrays combinators columns stack-checker.backend
|
||||
stack-checker.branches compiler.tree compiler.tree.combinators
|
||||
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
|
||||
;
|
||||
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
|
||||
IN: compiler.tree.dead-code.branches
|
||||
|
||||
M: #if mark-live-values* look-at-inputs ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tree.debugger.tests
|
||||
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
|
||||
IN: compiler.tree.debugger.tests
|
||||
|
||||
[ [ <=> ] sort ] optimized.
|
||||
[ <reversed> [ print ] each ] optimizer-report.
|
||||
|
|
@ -11,6 +11,8 @@ compiler.tree.normalization
|
|||
compiler.tree.cleanup
|
||||
compiler.tree.propagation
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis
|
||||
compiler.tree.tuple-unboxing
|
||||
compiler.tree.def-use
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
|
|
@ -209,6 +211,8 @@ SYMBOL: node-count
|
|||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
apply-identities
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ TUPLE: definition value node uses ;
|
|||
ERROR: no-def-error value ;
|
||||
|
||||
: def-of ( value -- definition )
|
||||
dup def-use get at* [ nip ] [ no-def-error ] if ;
|
||||
def-use get ?at [ no-def-error ] unless ;
|
||||
|
||||
ERROR: multiple-defs-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel tools.test compiler.tree compiler.tree.builder
|
||||
compiler.tree.def-use compiler.tree.def-use.simplified accessors
|
||||
sequences sorting classes ;
|
||||
compiler.tree.recursive compiler.tree.def-use
|
||||
compiler.tree.def-use.simplified accessors sequences sorting classes ;
|
||||
IN: compiler.tree.def-use.simplified
|
||||
|
||||
[ { #call #return } ] [
|
||||
|
|
@ -8,3 +8,17 @@ IN: compiler.tree.def-use.simplified
|
|||
first out-d>> first actually-used-by
|
||||
[ node>> class ] map natural-sort
|
||||
] unit-test
|
||||
|
||||
: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive
|
||||
|
||||
[ { #introduce } ] [
|
||||
[ word-1 ] build-tree analyze-recursive compute-def-use
|
||||
last in-d>> first actually-defined-by
|
||||
[ node>> class ] map natural-sort
|
||||
] unit-test
|
||||
|
||||
[ { #if #return } ] [
|
||||
[ word-1 ] build-tree analyze-recursive compute-def-use
|
||||
first out-d>> first actually-used-by
|
||||
[ node>> class ] map natural-sort
|
||||
] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel fry vectors
|
||||
compiler.tree compiler.tree.def-use ;
|
||||
USING: sequences kernel fry vectors accessors namespaces assocs sets
|
||||
stack-checker.branches compiler.tree compiler.tree.def-use ;
|
||||
IN: compiler.tree.def-use.simplified
|
||||
|
||||
! Simplified def-use follows chains of copies.
|
||||
|
|
@ -9,32 +9,85 @@ IN: compiler.tree.def-use.simplified
|
|||
! A 'real' usage is a usage of a value that is not a #renaming.
|
||||
TUPLE: real-usage value node ;
|
||||
|
||||
! Def
|
||||
GENERIC: actually-defined-by* ( value node -- real-usage )
|
||||
<PRIVATE
|
||||
|
||||
: actually-defined-by ( value -- real-usage )
|
||||
dup defined-by actually-defined-by* ;
|
||||
SYMBOLS: visited accum ;
|
||||
|
||||
: if-not-visited ( value quot -- )
|
||||
over visited get key?
|
||||
[ 2drop ] [ over visited get conjoin call ] if ; inline
|
||||
|
||||
: with-simplified-def-use ( quot -- real-usages )
|
||||
[
|
||||
H{ } clone visited set
|
||||
H{ } clone accum set
|
||||
call
|
||||
accum get keys
|
||||
] with-scope ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Def
|
||||
GENERIC: actually-defined-by* ( value node -- )
|
||||
|
||||
: (actually-defined-by) ( value -- )
|
||||
[ dup defined-by actually-defined-by* ] if-not-visited ;
|
||||
|
||||
M: #renaming actually-defined-by*
|
||||
inputs/outputs swap [ index ] dip nth actually-defined-by ;
|
||||
inputs/outputs swap [ index ] dip nth (actually-defined-by) ;
|
||||
|
||||
M: #return-recursive actually-defined-by* real-usage boa ;
|
||||
M: #call-recursive actually-defined-by*
|
||||
[ out-d>> index ] [ label>> return>> in-d>> nth ] bi
|
||||
(actually-defined-by) ;
|
||||
|
||||
M: node actually-defined-by* real-usage boa ;
|
||||
M: #enter-recursive actually-defined-by*
|
||||
[ out-d>> index ] keep
|
||||
[ in-d>> nth (actually-defined-by) ]
|
||||
[ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ;
|
||||
|
||||
M: #phi actually-defined-by*
|
||||
[ out-d>> index ] [ phi-in-d>> ] bi
|
||||
[
|
||||
nth dup +bottom+ eq?
|
||||
[ drop ] [ (actually-defined-by) ] if
|
||||
] with each ;
|
||||
|
||||
M: node actually-defined-by*
|
||||
real-usage boa accum get conjoin ;
|
||||
|
||||
: actually-defined-by ( value -- real-usages )
|
||||
[ (actually-defined-by) ] with-simplified-def-use ;
|
||||
|
||||
! Use
|
||||
GENERIC# actually-used-by* 1 ( value node accum -- )
|
||||
GENERIC: actually-used-by* ( value node -- )
|
||||
|
||||
: (actually-used-by) ( value accum -- )
|
||||
[ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
|
||||
: (actually-used-by) ( value -- )
|
||||
[ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
|
||||
|
||||
M: #renaming actually-used-by*
|
||||
[ inputs/outputs [ indices ] dip nths ] dip
|
||||
'[ _ (actually-used-by) ] each ;
|
||||
inputs/outputs [ indices ] dip nths
|
||||
[ (actually-used-by) ] each ;
|
||||
|
||||
M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
|
||||
M: #return-recursive actually-used-by*
|
||||
[ in-d>> index ] keep
|
||||
[ out-d>> nth (actually-used-by) ]
|
||||
[ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ;
|
||||
|
||||
M: node actually-used-by* [ real-usage boa ] dip push ;
|
||||
M: #call-recursive actually-used-by*
|
||||
[ in-d>> index ] [ label>> enter-out>> nth ] bi
|
||||
(actually-used-by) ;
|
||||
|
||||
M: #enter-recursive actually-used-by*
|
||||
[ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ;
|
||||
|
||||
M: #phi actually-used-by*
|
||||
[ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi
|
||||
(actually-used-by) ;
|
||||
|
||||
M: #recursive actually-used-by* 2drop ;
|
||||
|
||||
M: node actually-used-by*
|
||||
real-usage boa accum get conjoin ;
|
||||
|
||||
: actually-used-by ( value -- real-usages )
|
||||
10 <vector> [ (actually-used-by) ] keep ;
|
||||
[ (actually-used-by) ] with-simplified-def-use ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.tree.escape-analysis.check.tests
|
||||
USING: compiler.tree.escape-analysis.check tools.test accessors kernel
|
||||
kernel.private math compiler.tree.builder compiler.tree.normalization
|
||||
compiler.tree.propagation compiler.tree.cleanup ;
|
||||
IN: compiler.tree.escape-analysis.check.tests
|
||||
|
||||
: test-checker ( quot -- ? )
|
||||
build-tree normalize propagate cleanup run-escape-analysis? ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
IN: compiler.tree.escape-analysis.tests
|
||||
USING: compiler.tree.escape-analysis
|
||||
compiler.tree.escape-analysis.allocations compiler.tree.builder
|
||||
compiler.tree.recursive compiler.tree.normalization
|
||||
|
|
@ -10,6 +9,7 @@ classes.tuple namespaces
|
|||
compiler.tree.propagation.info stack-checker.errors
|
||||
compiler.tree.checker
|
||||
kernel.private vectors ;
|
||||
IN: compiler.tree.escape-analysis.tests
|
||||
|
||||
GENERIC: count-unboxed-allocations* ( m node -- n )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.tree.escape-analysis.recursive.tests
|
||||
USING: kernel tools.test namespaces sequences
|
||||
compiler.tree.escape-analysis.recursive
|
||||
compiler.tree.escape-analysis.allocations ;
|
||||
IN: compiler.tree.escape-analysis.recursive.tests
|
||||
|
||||
H{ } clone allocations set
|
||||
<escaping-values> escaping-values set
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs combinators.short-circuit
|
||||
classes classes.builtin classes.tuple classes.singleton
|
||||
math.partial-dispatch fry assocs combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -45,6 +45,7 @@ M: predicate finalize-word
|
|||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
{ [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.modular-arithmetic.tests
|
||||
USING: kernel kernel.private tools.test math math.partial-dispatch
|
||||
math.private accessors slots.private sequences sequences.private strings sbufs
|
||||
compiler.tree.builder
|
||||
compiler.tree.normalization
|
||||
compiler.tree.debugger
|
||||
alien.accessors layouts combinators byte-arrays ;
|
||||
prettyprint math.private accessors slots.private sequences
|
||||
sequences.private strings sbufs compiler.tree.builder
|
||||
compiler.tree.normalization compiler.tree.debugger alien.accessors
|
||||
layouts combinators byte-arrays arrays ;
|
||||
IN: compiler.tree.modular-arithmetic.tests
|
||||
|
||||
: test-modular-arithmetic ( quot -- quot' )
|
||||
cleaned-up-tree nodes>quot ;
|
||||
|
|
@ -93,8 +92,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare [ 256 mod ] map
|
||||
|
|
@ -137,9 +134,14 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >fixnum 255 >R R> fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
|
|
@ -176,3 +178,115 @@ cell {
|
|||
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
|
||||
{ >integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >bignum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
|
||||
{ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ [ 1 ] [ 4 ] if ] ] [
|
||||
[ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic
|
||||
] unit-test
|
||||
|
||||
[ [ [ 1 ] [ 2 ] if ] ] [
|
||||
[ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 0 1000 [ 1 + dup >fixnum . ] times drop ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 0 1000 [ 1 + ] times >fixnum ]
|
||||
{ fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ f >fixnum ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ >fixnum ] 2dip set-alien-unsigned-1 ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 123 >bignum bitand >fixnum ]
|
||||
{ >bignum fixnum>bignum bignum-bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
! Shifts
|
||||
[ t ] [
|
||||
[
|
||||
[ 0 ] 2dip { array } declare [
|
||||
hashcode* >fixnum swap [
|
||||
[ -2 shift ] [ 5 shift ] bi
|
||||
+ +
|
||||
] keep bitxor >fixnum
|
||||
] with each
|
||||
] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
|
||||
] unit-test
|
||||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit layouts alien.accessors
|
||||
USING: math math.intervals math.private math.partial-dispatch
|
||||
namespaces sequences sets accessors assocs words kernel memoize fry
|
||||
combinators combinators.short-circuit layouts alien.accessors
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.def-use
|
||||
compiler.tree.def-use.simplified
|
||||
compiler.tree.late-optimizations ;
|
||||
|
|
@ -19,17 +20,24 @@ IN: compiler.tree.modular-arithmetic
|
|||
! ==>
|
||||
! [ >fixnum ] bi@ fixnum+fast
|
||||
|
||||
! Words where the low-order bits of the output only depends on the
|
||||
! low-order bits of the input. If the output is only used for its
|
||||
! low-order bits, then the word can be converted into a form that is
|
||||
! cheaper to compute.
|
||||
{ + - * bitand bitor bitxor } [
|
||||
[
|
||||
t "modular-arithmetic" set-word-prop
|
||||
] each-integer-derived-op
|
||||
] each
|
||||
|
||||
{ bitand bitor bitxor bitnot }
|
||||
{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
|
||||
[ t "modular-arithmetic" set-word-prop ] each
|
||||
|
||||
! Words that only use the low-order bits of their input. If the input
|
||||
! is a modular arithmetic word, then the input can be converted into
|
||||
! a form that is cheaper to compute.
|
||||
{
|
||||
>fixnum
|
||||
>fixnum bignum>fixnum float>fixnum
|
||||
set-alien-unsigned-1 set-alien-signed-1
|
||||
set-alien-unsigned-2 set-alien-signed-2
|
||||
}
|
||||
|
|
@ -38,80 +46,156 @@ cell 8 = [
|
|||
] when
|
||||
[ t "low-order" set-word-prop ] each
|
||||
|
||||
SYMBOL: modularize-values
|
||||
! Values which only have their low-order bits used. This set starts out
|
||||
! big and is gradually refined.
|
||||
SYMBOL: modular-values
|
||||
|
||||
: modular-value? ( value -- ? )
|
||||
modularize-values get key? ;
|
||||
modular-values get key? ;
|
||||
|
||||
: modularize-value ( value -- ) modularize-values get conjoin ;
|
||||
: modular-value ( value -- )
|
||||
modular-values get conjoin ;
|
||||
|
||||
GENERIC: maybe-modularize* ( value node -- )
|
||||
! Values which are known to be fixnums.
|
||||
SYMBOL: fixnum-values
|
||||
|
||||
: maybe-modularize ( value -- )
|
||||
actually-defined-by [ value>> ] [ node>> ] bi
|
||||
over actually-used-by length 1 = [
|
||||
maybe-modularize*
|
||||
] [ 2drop ] if ;
|
||||
: fixnum-value? ( value -- ? )
|
||||
fixnum-values get key? ;
|
||||
|
||||
M: #call maybe-modularize*
|
||||
dup word>> "modular-arithmetic" word-prop [
|
||||
[ modularize-value ]
|
||||
[ in-d>> [ maybe-modularize ] each ] bi*
|
||||
] [ 2drop ] if ;
|
||||
: fixnum-value ( value -- )
|
||||
fixnum-values get conjoin ;
|
||||
|
||||
M: node maybe-modularize* 2drop ;
|
||||
GENERIC: compute-modular-candidates* ( node -- )
|
||||
|
||||
GENERIC: compute-modularized-values* ( node -- )
|
||||
M: #push compute-modular-candidates*
|
||||
[ out-d>> first ] [ literal>> ] bi
|
||||
real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
|
||||
|
||||
M: #call compute-modularized-values*
|
||||
dup word>> "low-order" word-prop
|
||||
[ in-d>> first maybe-modularize ] [ drop ] if ;
|
||||
: small-shift? ( interval -- ? )
|
||||
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
|
||||
|
||||
M: node compute-modularized-values* drop ;
|
||||
: modular-word? ( #call -- ? )
|
||||
dup word>> { shift fixnum-shift bignum-shift } memq?
|
||||
[ node-input-infos second interval>> small-shift? ]
|
||||
[ word>> "modular-arithmetic" word-prop ]
|
||||
if ;
|
||||
|
||||
: compute-modularized-values ( nodes -- )
|
||||
[ compute-modularized-values* ] each-node ;
|
||||
: output-candidate ( #call -- )
|
||||
out-d>> first [ modular-value ] [ fixnum-value ] bi ;
|
||||
|
||||
: low-order-word? ( #call -- ? )
|
||||
word>> "low-order" word-prop ;
|
||||
|
||||
: input-candidiate ( #call -- )
|
||||
in-d>> first modular-value ;
|
||||
|
||||
M: #call compute-modular-candidates*
|
||||
{
|
||||
{ [ dup modular-word? ] [ output-candidate ] }
|
||||
{ [ dup low-order-word? ] [ input-candidiate ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: node compute-modular-candidates*
|
||||
drop ;
|
||||
|
||||
: compute-modular-candidates ( nodes -- )
|
||||
H{ } clone modular-values set
|
||||
H{ } clone fixnum-values set
|
||||
[ compute-modular-candidates* ] each-node ;
|
||||
|
||||
GENERIC: only-reads-low-order? ( node -- ? )
|
||||
|
||||
: output-modular? ( #call -- ? )
|
||||
out-d>> first modular-values get key? ;
|
||||
|
||||
M: #call only-reads-low-order?
|
||||
{
|
||||
[ low-order-word? ]
|
||||
[ { [ modular-word? ] [ output-modular? ] } 1&& ]
|
||||
} 1|| ;
|
||||
|
||||
M: node only-reads-low-order? drop f ;
|
||||
|
||||
SYMBOL: changed?
|
||||
|
||||
: only-used-as-low-order? ( value -- ? )
|
||||
actually-used-by [ node>> only-reads-low-order? ] all? ;
|
||||
|
||||
: (compute-modular-values) ( -- )
|
||||
modular-values get keys [
|
||||
dup only-used-as-low-order?
|
||||
[ drop ] [ modular-values get delete-at changed? on ] if
|
||||
] each ;
|
||||
|
||||
: compute-modular-values ( -- )
|
||||
[ changed? off (compute-modular-values) changed? get ] loop ;
|
||||
|
||||
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
||||
|
||||
M: #push optimize-modular-arithmetic*
|
||||
dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
|
||||
[ [ >fixnum ] change-literal ] when ;
|
||||
|
||||
: redundant->fixnum? ( #call -- ? )
|
||||
in-d>> first actually-defined-by value>> modular-value? ;
|
||||
in-d>> first actually-defined-by
|
||||
[ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
|
||||
|
||||
: optimize->fixnum ( #call -- nodes )
|
||||
dup redundant->fixnum? [ drop f ] when ;
|
||||
|
||||
: should-be->fixnum? ( #call -- ? )
|
||||
out-d>> first modular-value? ;
|
||||
|
||||
: optimize->integer ( #call -- nodes )
|
||||
dup out-d>> first actually-used-by dup length 1 = [
|
||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
||||
[ drop { } ] when
|
||||
] [ drop ] if ;
|
||||
dup should-be->fixnum? [ \ >fixnum >>word ] when ;
|
||||
|
||||
MEMO: fixnum-coercion ( flags -- nodes )
|
||||
! flags indicate which input parameters are already known to be fixnums,
|
||||
! and don't need a coercion as a result.
|
||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||
|
||||
: modular-value-info ( #call -- alist )
|
||||
[ in-d>> ] [ out-d>> ] bi append
|
||||
fixnum <class-info> '[ _ ] { } map>assoc ;
|
||||
|
||||
: optimize-modular-op ( #call -- nodes )
|
||||
dup out-d>> first modular-value? [
|
||||
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
|
||||
[
|
||||
[
|
||||
[ actually-defined-by value>> modular-value? ]
|
||||
[ actually-defined-by [ value>> modular-value? ] all? ]
|
||||
[ fixnum eq? ]
|
||||
bi* or
|
||||
] 2map fixnum-coercion
|
||||
] [ [ modular-variant ] change-word ] bi* suffix
|
||||
] when ;
|
||||
|
||||
: optimize-low-order-op ( #call -- nodes )
|
||||
dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
|
||||
[ ] [ in-d>> first ] [ info>> ] tri
|
||||
[ drop fixnum <class-info> ] change-at
|
||||
] when ;
|
||||
|
||||
: like->fixnum? ( #call -- ? )
|
||||
word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
|
||||
|
||||
: like->integer? ( #call -- ? )
|
||||
word>> { >integer >bignum fixnum>bignum } memq? ;
|
||||
|
||||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
[ drop ]
|
||||
{
|
||||
{ [ dup like->fixnum? ] [ optimize->fixnum ] }
|
||||
{ [ dup like->integer? ] [ optimize->integer ] }
|
||||
{ [ dup modular-word? ] [ optimize-modular-op ] }
|
||||
{ [ dup low-order-word? ] [ optimize-low-order-op ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: node optimize-modular-arithmetic* ;
|
||||
|
||||
: optimize-modular-arithmetic ( nodes -- nodes' )
|
||||
H{ } clone modularize-values set
|
||||
dup compute-modularized-values
|
||||
[ optimize-modular-arithmetic* ] map-nodes ;
|
||||
dup compute-modular-candidates compute-modular-values
|
||||
modular-values get assoc-empty? [
|
||||
[ optimize-modular-arithmetic* ] map-nodes
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: compiler.tree.normalization.tests
|
||||
USING: compiler.tree.builder compiler.tree.recursive
|
||||
compiler.tree.normalization
|
||||
compiler.tree.normalization.introductions
|
||||
compiler.tree.normalization.renaming
|
||||
compiler.tree compiler.tree.checker
|
||||
sequences accessors tools.test kernel math ;
|
||||
IN: compiler.tree.normalization.tests
|
||||
|
||||
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
USING: compiler.tree.optimizer tools.test ;
|
||||
IN: compiler.tree.optimizer.tests
|
||||
|
||||
|
||||
|
|
@ -153,7 +153,7 @@ ERROR: uninferable ;
|
|||
|
||||
: (value>quot) ( value-info -- quot )
|
||||
dup class>> {
|
||||
{ \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
|
||||
{ \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
|
||||
{ \ curry [
|
||||
slots>> third (value>quot)
|
||||
'[ [ obj>> ] [ quot>> @ ] bi ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tree.propagation.copy.tests
|
||||
USING: compiler.tree.propagation.copy tools.test namespaces kernel
|
||||
assocs ;
|
||||
IN: compiler.tree.propagation.copy.tests
|
||||
|
||||
H{ } clone copies set
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra classes.tuple
|
||||
classes.tuple.private kernel accessors math math.intervals namespaces
|
||||
sequences sequences.private words combinators
|
||||
sequences sequences.private words combinators memoize
|
||||
combinators.short-circuit byte-arrays strings arrays layouts
|
||||
cpu.architecture compiler.tree.propagation.copy ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
|
@ -78,21 +78,37 @@ UNION: fixed-length array byte-array string ;
|
|||
: empty-set? ( info -- ? )
|
||||
{
|
||||
[ class>> null-class? ]
|
||||
[ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
|
||||
[ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
|
||||
} 1|| ;
|
||||
|
||||
: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
|
||||
: min-value ( class -- n )
|
||||
{
|
||||
{ fixnum [ most-negative-fixnum ] }
|
||||
{ array-capacity [ 0 ] }
|
||||
[ drop -1/0. ]
|
||||
} case ;
|
||||
|
||||
: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
|
||||
: max-value ( class -- n )
|
||||
{
|
||||
{ fixnum [ most-positive-fixnum ] }
|
||||
{ array-capacity [ max-array-capacity ] }
|
||||
[ drop 1/0. ]
|
||||
} case ;
|
||||
|
||||
: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
|
||||
: class-interval ( class -- i )
|
||||
{
|
||||
{ fixnum [ fixnum-interval ] }
|
||||
{ array-capacity [ array-capacity-interval ] }
|
||||
[ drop full-interval ]
|
||||
} case ;
|
||||
|
||||
: wrap-interval ( interval class -- interval' )
|
||||
{
|
||||
{ fixnum [ interval->fixnum ] }
|
||||
{ array-capacity [ max-array-capacity [a,a] interval-rem ] }
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ nip class-interval ] }
|
||||
{ [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
} cond ;
|
||||
|
||||
: init-interval ( info -- info )
|
||||
dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.single generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart hints
|
||||
locals
|
||||
combinators.short-circuit words namespaces continuations classes
|
||||
fry hints locals
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.recursive
|
||||
|
|
@ -14,19 +14,6 @@ compiler.tree.propagation.info
|
|||
compiler.tree.propagation.nodes ;
|
||||
IN: compiler.tree.propagation.inlining
|
||||
|
||||
! We count nodes up-front; if there are relatively few nodes,
|
||||
! we are more eager to inline
|
||||
SYMBOL: node-count
|
||||
|
||||
: count-nodes ( nodes -- n )
|
||||
0 swap [ drop 1+ ] each-node ;
|
||||
|
||||
: compute-node-count ( nodes -- ) count-nodes node-count set ;
|
||||
|
||||
! We try not to inline the same word too many times, to avoid
|
||||
! combinatorial explosion
|
||||
SYMBOL: inlining-count
|
||||
|
||||
! Splicing nodes
|
||||
: splicing-call ( #call word -- nodes )
|
||||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||
|
|
@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ;
|
|||
dupd inlining-math-partial eliminate-dispatch ;
|
||||
|
||||
! Method body inlining
|
||||
SYMBOL: recursive-calls
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! special-case
|
||||
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! recursive and inline
|
||||
{ [ dup recursive-calls get key? ] [ drop 10 ] }
|
||||
! inline
|
||||
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 2 + ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
[ drop 0 ]
|
||||
} cond
|
||||
] sigma ;
|
||||
|
||||
: flat-length ( word -- n )
|
||||
H{ } clone recursive-calls [
|
||||
[ recursive-calls get conjoin ]
|
||||
[ def>> (flat-length) 5 /i ]
|
||||
bi
|
||||
] with-variable ;
|
||||
|
||||
: classes-known? ( #call -- ? )
|
||||
in-d>> [
|
||||
value-info class>>
|
||||
[ class-types length 1 = ]
|
||||
[ union-class? not ]
|
||||
bi and
|
||||
] any? ;
|
||||
|
||||
: node-count-bias ( -- n )
|
||||
45 node-count get [-] 8 /i ;
|
||||
|
||||
: body-length-bias ( word -- n )
|
||||
[ flat-length ] [ inlining-count get at 0 or ] bi
|
||||
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
[ body-length-bias ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
tri
|
||||
node-count-bias
|
||||
loop-nesting get 0 or 2 *
|
||||
] bi*
|
||||
] sum-outputs ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
||||
SYMBOL: history
|
||||
|
||||
: already-inlined? ( obj -- ? ) history get memq? ;
|
||||
|
||||
: add-to-history ( obj -- ) history [ swap suffix ] change ;
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
[ inlining-count get inc-at ]
|
||||
[ add-to-history ]
|
||||
bi ;
|
||||
|
||||
:: inline-word ( #call word -- ? )
|
||||
word already-inlined? [ f ] [
|
||||
#call word splicing-body [
|
||||
[
|
||||
word remember-inlining
|
||||
[ ] [ count-nodes ] [ (propagate) ] tri
|
||||
word add-to-history
|
||||
dup (propagate)
|
||||
] with-scope
|
||||
[ #call (>>body) ] [ node-count +@ ] bi* t
|
||||
#call (>>body) t
|
||||
] [ f ] if*
|
||||
] if ;
|
||||
|
||||
: inline-method-body ( #call word -- ? )
|
||||
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
||||
|
||||
: always-inline-word? ( word -- ? )
|
||||
{ curry compose } memq? ;
|
||||
|
||||
: never-inline-word? ( word -- ? )
|
||||
[ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
|
||||
{ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
|
||||
|
||||
: custom-inlining? ( word -- ? )
|
||||
"custom-inlining" word-prop ;
|
||||
|
|
@ -217,7 +133,7 @@ SYMBOL: history
|
|||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
{ [ dup inline? ] [ inline-word ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue