diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index 7c64680a83..2379e3e80d 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -1,6 +1,6 @@ -IN: alarms.tests USING: alarms alarms.private kernel calendar sequences tools.test threads concurrency.count-downs ; +IN: alarms.tests [ ] [ 1 diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index f9fdce806f..9943d39ad1 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -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 ; : ( quot time frequency -- alarm ) check-alarm 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 ] diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index e4a0e4dcf0..d793814c28 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -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 ] ; @@ -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 ; diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index ea9e881fd4..0de26aad20 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -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 diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6e398667ec..2eba6a2b9e 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -13,17 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *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? ; : ( -- 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-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 integer >>class + integer >>boxed-class [ alien-signed-8 ] >>getter [ set-alien-signed-8 ] >>setter 8 >>size @@ -321,6 +330,7 @@ CONSTANT: primitive-types integer >>class + integer >>boxed-class [ alien-unsigned-8 ] >>getter [ set-alien-unsigned-8 ] >>setter 8 >>size @@ -331,6 +341,7 @@ CONSTANT: primitive-types integer >>class + integer >>boxed-class [ alien-signed-cell ] >>getter [ set-alien-signed-cell ] >>setter bootstrap-cell >>size @@ -341,6 +352,7 @@ CONSTANT: primitive-types integer >>class + integer >>boxed-class [ alien-unsigned-cell ] >>getter [ set-alien-unsigned-cell ] >>setter bootstrap-cell >>size @@ -351,6 +363,7 @@ CONSTANT: primitive-types integer >>class + integer >>boxed-class [ alien-signed-4 ] >>getter [ set-alien-signed-4 ] >>setter 4 >>size @@ -361,6 +374,7 @@ CONSTANT: primitive-types integer >>class + integer >>boxed-class [ alien-unsigned-4 ] >>getter [ set-alien-unsigned-4 ] >>setter 4 >>size @@ -371,6 +385,7 @@ CONSTANT: primitive-types fixnum >>class + fixnum >>boxed-class [ alien-signed-2 ] >>getter [ set-alien-signed-2 ] >>setter 2 >>size @@ -381,6 +396,7 @@ CONSTANT: primitive-types fixnum >>class + fixnum >>boxed-class [ alien-unsigned-2 ] >>getter [ set-alien-unsigned-2 ] >>setter 2 >>size @@ -391,6 +407,7 @@ CONSTANT: primitive-types fixnum >>class + fixnum >>boxed-class [ alien-signed-1 ] >>getter [ set-alien-signed-1 ] >>setter 1 >>size @@ -401,6 +418,7 @@ CONSTANT: primitive-types fixnum >>class + fixnum >>boxed-class [ alien-unsigned-1 ] >>getter [ set-alien-unsigned-1 ] >>setter 1 >>size @@ -420,25 +438,27 @@ CONSTANT: primitive-types 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 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 diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 0bff73b898..2844e505b5 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index c80ead73f0..b0229358d1 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -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 - >> +>> diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor deleted file mode 100644 index c2df22be1d..0000000000 --- a/basis/alien/complex/functor/functor-tests.factor +++ /dev/null @@ -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 diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index fc9e594be5..98d412639f 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -30,6 +30,7 @@ define-struct T c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot +number >>boxed-class drop ;FUNCTOR diff --git a/basis/alien/destructors/destructors-tests.factor b/basis/alien/destructors/destructors-tests.factor deleted file mode 100644 index 4f434452d4..0000000000 --- a/basis/alien/destructors/destructors-tests.factor +++ /dev/null @@ -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 diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 54b799f675..013c4d6f6a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -357,15 +357,15 @@ M: character-type () : (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 ; diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor index 13eb134ea9..f1dc228d83 100644 --- a/basis/alien/libraries/libraries-tests.factor +++ b/basis/alien/libraries/libraries-tests.factor @@ -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 @@ -7,4 +7,4 @@ USING: alien.libraries alien.syntax tools.test kernel ; [ ] [ "doesnotexist" dlopen dlclose ] unit-test -[ "fdasfsf" dll-valid? drop ] must-fail \ No newline at end of file +[ "fdasfsf" dll-valid? drop ] must-fail diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 231f1bd428..3f84377d5c 100755 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -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" } diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index b618e7974b..5c1fb4063b 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -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 diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index d479e6d498..b70aa3557c 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -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 ; diff --git a/basis/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor index 6f39b32a01..8551ba53ef 100644 --- a/basis/ascii/ascii-tests.factor +++ b/basis/ascii/ascii-tests.factor @@ -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 diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 47147fa306..eb2c9193a3 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -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 ] diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor index f408cc82a8..2ef54441e1 100644 --- a/basis/biassocs/biassocs-tests.factor +++ b/basis/biassocs/biassocs-tests.factor @@ -1,5 +1,5 @@ -IN: biassocs.tests USING: biassocs assocs namespaces tools.test ; +IN: biassocs.tests "h" set @@ -29,4 +29,4 @@ H{ { "a" "A" } { "b" "B" } } "a" set [ "A" ] [ "a" "b" get at ] unit-test -[ "a" ] [ "A" "b" get value-at ] unit-test \ No newline at end of file +[ "a" ] [ "A" "b" get value-at ] unit-test diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 63d2697418..f2ea7503f4 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -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 diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index cdec87b61d..7aea3c458a 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; dup 0 = [ ] [ - [ log2 1+ 0 ] keep + [ log2 1 + 0 ] keep [ dup 0 = ] [ [ pick underlying>> pick set-alien-unsigned-1 ] keep - [ 1+ ] [ -8 shift ] bi* + [ 1 + ] [ -8 shift ] bi* ] until 2drop ] if ; diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index e77bb43986..6a1366a1ea 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/basis/bit-sets/bit-sets-tests.factor @@ -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 } diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 41efdbd0d2..5af44b59f7 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -1,5 +1,5 @@ -IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; +IN: bit-vectors.tests [ 0 ] [ 123 length ] unit-test diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index a5b1b43acd..794faa6055 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -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 } diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 2aa0059542..0eef54dc66 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -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 diff --git a/basis/bootstrap/compiler/timing/timing.factor b/basis/bootstrap/compiler/timing/timing.factor index e1466e3409..04c75c549d 100644 --- a/basis/bootstrap/compiler/timing/timing.factor +++ b/basis/bootstrap/compiler/timing/timing.factor @@ -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 \ No newline at end of file diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index e7070d3cf2..c5c6460041 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -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 diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index d76588e4e4..38cb5c12fe 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -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 ; diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor index d70a253e5f..7f25ce9c01 100644 --- a/basis/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -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 ; diff --git a/basis/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor index 27b2f6b181..3bab31daeb 100644 --- a/basis/bootstrap/math/math.factor +++ b/basis/bootstrap/math/math.factor @@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ; "math.ratios" require "math.floats" require -"math.complex" require \ No newline at end of file +"math.complex" require diff --git a/basis/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor index 71fc1c9a7b..3bcb735217 100644 --- a/basis/boxes/boxes-tests.factor +++ b/basis/boxes/boxes-tests.factor @@ -1,5 +1,5 @@ -IN: boxes.tests USING: boxes namespaces tools.test accessors ; +IN: boxes.tests [ ] [ "b" set ] unit-test diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index f1b9a52303..5c381b7db0 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -8,4 +8,3 @@ SYNTAX: HEX{ [ blank? not ] filter 2 group [ hex> ] B{ } map-as parsed ; - diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor deleted file mode 100644 index cbf4f64e22..0000000000 --- a/basis/cache/cache-tests.factor +++ /dev/null @@ -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 diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor index f16461bf45..3dab1acac8 100644 --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -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 ; \ No newline at end of file + ] change-assoc drop ; diff --git a/basis/cairo/cairo-tests.factor b/basis/cairo/cairo-tests.factor index bf7c468774..cb19259984 100644 --- a/basis/cairo/cairo-tests.factor +++ b/basis/cairo/cairo-tests.factor @@ -1,8 +1,8 @@ -IN: cairo.tests USING: cairo tools.test math.rectangles accessors ; +IN: cairo.tests [ { 10 20 } ] [ { 10 20 } [ { 0 1 } { 3 4 } fill-rect ] make-bitmap-image dim>> -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 3aae10f6a7..71e052bb6c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -20,14 +20,14 @@ HELP: { $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 >gmt midnight ." + { $example "USING: accessors calendar prettyprint ;" + "2010 12 25 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." } ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4b58b1b496..a8bb60cbf3 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -34,25 +34,25 @@ C: timestamp : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -ERROR: not-a-month n ; +ERROR: not-a-month ; M: not-a-month summary drop "Months are indexed starting at 1" ; -: 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 year 3 1 - after=? [ 1+ ] when + after=? [ 1 + ] when ] when ; : day-of-year ( timestamp -- n ) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index ad43cc2f1d..6aa4126ff9 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -68,8 +68,8 @@ M: array month. ( pair -- ) [ (days-in-month) day-abbreviations2 " " join print ] 2tri over " " 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 diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor index 1e51fb06d8..99fa41cd40 100644 --- a/basis/channels/examples/examples.factor +++ b/basis/channels/examples/examples.factor @@ -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) ; diff --git a/basis/checksums/fnv1/fnv1.factor b/basis/checksums/fnv1/fnv1.factor index f221cefef2..5cc6b02425 100644 --- a/basis/checksums/fnv1/fnv1.factor +++ b/basis/checksums/fnv1/fnv1.factor @@ -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 diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index b7f388c002..730c0b8516 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -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 diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index b4a9d547f2..c3c4860f95 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -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 } 0 swap virtual@ drop ] unit-test [ 2 ] [ { 0 1 2 3 4 } 2 swap virtual@ drop ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9995567ec8..b3be4651cd 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -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 ; : ( capacity -- growing-circular ) { } new-sequence 0 0 growing-circular boa ; diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor index 4ed9d7de67..a798eb15ba 100644 --- a/basis/cocoa/callbacks/callbacks.factor +++ b/basis/cocoa/callbacks/callbacks.factor @@ -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 diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 4b5af2e39d..c657a5e6e8 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -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" } diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a3fa788f20..9da285f34c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -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 ] } diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor index 4f74cd850a..e5d7dfd239 100644 --- a/basis/cocoa/plists/plists-tests.factor +++ b/basis/cocoa/plists/plists-tests.factor @@ -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 @@ -37,4 +37,4 @@ assocs cocoa.enumeration ; [ 3.5 ] [ 3.5 >cf &CFRelease plist> ] unit-test -] with-destructors \ No newline at end of file +] with-destructors diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor index a825cacda8..278906ce0e 100644 --- a/basis/colors/hsv/hsv-tests.factor +++ b/basis/colors/hsv/hsv-tests.factor @@ -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 @@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ; [ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test [ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test -[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test \ No newline at end of file +[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index 657b9e0a25..a53f5c1185 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -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 diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 66ba001094..db7056bd5a 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -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&& diff --git a/basis/combinators/short-circuit/smart/smart-tests.factor b/basis/combinators/short-circuit/smart/smart-tests.factor index 7ec4a0e657..c8cf8ffc1b 100644 --- a/basis/combinators/short-circuit/smart/smart-tests.factor +++ b/basis/combinators/short-circuit/smart/smart-tests.factor @@ -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 diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor index b80e7294d1..7264a07917 100644 --- a/basis/combinators/short-circuit/smart/smart.factor +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -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 > [ "Cannot determine arity" throw ] when - effect-height neg 1+ ; + dup terminated?>> [ cannot-determine-arity ] when + effect-height neg 1 + ; PRIVATE> diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index d8ee89ef2d..59b65d91cd 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -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" } } ; diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index a18ef1f3b8..399b4dc36f 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -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 @@ -46,4 +46,4 @@ IN: combinators.smart.tests [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test -[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test \ No newline at end of file +[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor deleted file mode 100644 index 79165f2c96..0000000000 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ /dev/null @@ -1 +0,0 @@ -IN: compiler.cfg.alias-analysis.tests diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index f6834c131d..526df79cb3 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 ; @@ -285,4 +285,4 @@ M: insn eliminate-dead-stores* ; eliminate-dead-stores ; : alias-analysis ( cfg -- cfg' ) - [ alias-analysis-step ] local-optimization ; \ No newline at end of file + [ alias-analysis-step ] local-optimization ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 08c43f203c..60528a61bb 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -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 ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor index d73bd866a0..f3790fd338 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor @@ -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 ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index e5583a14ab..1daabf6f0e 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -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 ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 76b10dda01..0155ea519d 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -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 ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 2de7c7c3d1..b2f25fdeb1 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -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 [ diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 0c40b93ba6..7b74d1c258 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -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>> [ swap set ] each-index ] + [ in-r>> [ 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/cfg-tests.factor b/basis/compiler/cfg/cfg-tests.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index f856efac78..369e6ebc32 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -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? ; -: ( entry word label -- cfg ) f f cfg boa ; +: ( 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 ; diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 812a5a1a7f..6919ba8b9b 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -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 ] [ ] diff --git a/basis/compiler/cfg/critical-edges/critical-edges-tests.factor b/basis/compiler/cfg/critical-edges/critical-edges-tests.factor deleted file mode 100644 index 88383e2e1e..0000000000 --- a/basis/compiler/cfg/critical-edges/critical-edges-tests.factor +++ /dev/null @@ -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 \ No newline at end of file diff --git a/basis/compiler/cfg/critical-edges/critical-edges.factor b/basis/compiler/cfg/critical-edges/critical-edges.factor deleted file mode 100644 index 2a42df4bbf..0000000000 --- a/basis/compiler/cfg/critical-edges/critical-edges.factor +++ /dev/null @@ -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 [ 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 975adfa6cb..275a4585b0 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -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 :> 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 -- ) diff --git a/basis/compiler/cfg/dce/dce-tests.factor b/basis/compiler/cfg/dce/dce-tests.factor index de2ed787b7..6a7ef08257 100644 --- a/basis/compiler/cfg/dce/dce-tests.factor +++ b/basis/compiler/cfg/dce/dce-tests.factor @@ -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 diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index fdc6601de4..dd42475a13 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -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 ] diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 26bf0eca56..33f87ff1d4 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -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* - > pprint* ] [ n>> pprint* ] bi - block> ; - : pprint-loc ( loc word -- ) > pprint* block> ; M: ds-loc pprint* \ D pprint-loc ; @@ -71,4 +69,12 @@ M: rs-loc pprint* \ R pprint-loc ; 0 1 edge 1 { 2 3 } edges 2 4 edge - 3 4 edge ; \ No newline at end of file + 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/def-use/def-use-tests.factor b/basis/compiler/cfg/def-use/def-use-tests.factor index 1153d9ea81..a4f0819397 100644 --- a/basis/compiler/cfg/def-use/def-use-tests.factor +++ b/basis/compiler/cfg/def-use/def-use-tests.factor @@ -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 diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 8e8fbf3a2d..c56bd80779 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 ; diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index a3b9fc0223..b24e51abfb 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -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 diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 325bed74ff..d21e81526e 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -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? ; diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor index 2a31a20b72..605c572cb3 100644 --- a/basis/compiler/cfg/empty-blocks/empty-blocks.factor +++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor @@ -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 - + +> first ] [ nip ] if ] 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 -- ? ) { @@ -32,7 +38,10 @@ IN: compiler.cfg.empty-blocks [ successors>> length 1 = ] [ 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 ; \ No newline at end of file + changed? get [ cfg-changed ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index b324214602..5580de9a47 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -1,26 +1,26 @@ -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 [ ] [ test-gc-checks ] unit-test -[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test \ No newline at end of file +[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index c34f2c42a3..21a60768ea 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -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 ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 4c1999943f..04fddbb203 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -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 \ No newline at end of file +: ^^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 \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 0a52f1aa94..4cf4340bd7 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 -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 diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 04d841f2d1..246a2cb924 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 8afd9f80ca..d4aa2750c0 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -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 ) diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 84a0bc9ca0..152be80286 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2618db0904..363197c3c0 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 93139a19a3..79e56c08ad 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index d55266e6e4..4b504d97f5 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 -- ) [ diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor deleted file mode 100644 index ef8a9c56f8..0000000000 --- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor +++ /dev/null @@ -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 ; - \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 874523d70a..1a2b0f2f2b 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index 3e646b40f0..cf120eae3b 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 071118d60f..16f1ccf96a 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index c9c1b77a0d..68ff8d4f88 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -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. ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 2164cef429..b7a97e75c6 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1,7 +1,7 @@ IN: compiler.cfg.linear-scan.tests USING: tools.test random sorting sequences sets hashtables assocs kernel fry arrays splitting namespaces math accessors vectors locals -math.order grouping strings strings.private classes +math.order grouping strings strings.private classes layouts cpu.architecture compiler.cfg compiler.cfg.optimizer @@ -11,6 +11,7 @@ compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.linearization compiler.cfg.debugger +compiler.cfg.def-use compiler.cfg.comparisons compiler.cfg.linear-scan compiler.cfg.linear-scan.numbering @@ -75,29 +76,35 @@ check-numbering? on { T{ live-range f 0 5 } } 0 split-ranges ] unit-test -H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +cfg new 0 >>spill-area-size cfg set H{ } spill-slots set +H{ + { 1 single-float-rep } + { 2 single-float-rep } + { 3 single-float-rep } +} representations set + [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 0 } { end 2 } { uses V{ 0 1 } } { ranges V{ T{ live-range f 0 2 } } } - { spill-to 10 } + { spill-to 0 } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 5 } { end 5 } { uses V{ 5 } } { ranges V{ T{ live-range f 5 5 } } } - { reload-from 10 } + { reload-from 0 } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 0 } { end 5 } { uses V{ 0 1 5 } } @@ -107,24 +114,24 @@ H{ } spill-slots set [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { vreg 2 } { start 0 } { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 11 } + { spill-to 4 } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { vreg 2 } { start 1 } { end 5 } { uses V{ 1 5 } } { ranges V{ T{ live-range f 1 5 } } } - { reload-from 11 } + { reload-from 4 } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { vreg 2 } { start 0 } { end 5 } { uses V{ 0 1 5 } } @@ -134,24 +141,24 @@ H{ } spill-slots set [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { vreg 3 } { start 0 } { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 12 } + { spill-to 8 } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { vreg 3 } { start 20 } { end 30 } { uses V{ 20 30 } } { ranges V{ T{ live-range f 20 30 } } } - { reload-from 12 } + { reload-from 8 } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { vreg 3 } { start 0 } { end 30 } { uses V{ 0 20 30 } } @@ -159,6 +166,12 @@ H{ } spill-slots set } 10 split-for-spill ] unit-test +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } +} representations set + [ { 3 @@ -169,21 +182,21 @@ H{ } spill-slots set { int-regs V{ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { reg 1 } { start 1 } { end 15 } { uses V{ 1 3 7 10 15 } } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { vreg 2 } { reg 2 } { start 3 } { end 8 } { uses V{ 3 4 8 } } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { vreg 3 } { reg 3 } { start 3 } { end 10 } @@ -194,7 +207,7 @@ H{ } spill-slots set } active-intervals set H{ } inactive-intervals set T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 5 } { end 5 } { uses V{ 5 } } @@ -212,14 +225,14 @@ H{ } spill-slots set { int-regs V{ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { reg 1 } { start 1 } { end 15 } { uses V{ 1 } } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { vreg 2 } { reg 2 } { start 3 } { end 8 } @@ -230,7 +243,7 @@ H{ } spill-slots set } active-intervals set H{ } inactive-intervals set T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { vreg 3 } { start 5 } { end 5 } { uses V{ 5 } } @@ -238,10 +251,12 @@ H{ } spill-slots set spill-status ] unit-test +H{ { 1 int-rep } { 2 int-rep } } representations set + [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } @@ -255,14 +270,14 @@ H{ } spill-slots set [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 10 } { uses V{ 0 10 } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 11 } { end 20 } { uses V{ 11 20 } } @@ -276,14 +291,14 @@ H{ } spill-slots set [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 60 } { uses V{ 30 60 } } @@ -297,14 +312,14 @@ H{ } spill-slots set [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 200 } { uses V{ 30 200 } } @@ -318,14 +333,14 @@ H{ } spill-slots set [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 100 } { uses V{ 30 100 } } @@ -337,32 +352,39 @@ H{ } spill-slots set ] must-fail ! Problem with spilling intervals with no more usages after the spill location +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + { 4 int-rep } + { 5 int-rep } +} representations set [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 20 } { uses V{ 0 10 20 } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 0 } { end 20 } { uses V{ 0 10 20 } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval - { vreg T{ vreg { n 3 } { reg-class int-regs } } } + { vreg 3 } { start 4 } { end 8 } { uses V{ 6 } } { ranges V{ T{ live-range f 4 8 } } } } T{ live-interval - { vreg T{ vreg { n 4 } { reg-class int-regs } } } + { vreg 4 } { start 4 } { end 8 } { uses V{ 8 } } @@ -371,7 +393,7 @@ H{ } spill-slots set ! This guy will invoke the 'spill partially available' code path T{ live-interval - { vreg T{ vreg { n 5 } { reg-class int-regs } } } + { vreg 5 } { start 4 } { end 8 } { uses V{ 8 } } @@ -382,13 +404,12 @@ H{ } spill-slots set check-linear-scan ] unit-test - ! Test spill-new code path [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 10 } { uses V{ 0 6 10 } } @@ -397,7 +418,7 @@ H{ } spill-slots set ! This guy will invoke the 'spill new' code path T{ live-interval - { vreg T{ vreg { n 5 } { reg-class int-regs } } } + { vreg 5 } { start 2 } { end 8 } { uses V{ 8 } } @@ -408,968 +429,6 @@ H{ } spill-slots set check-linear-scan ] unit-test -SYMBOL: available - -SYMBOL: taken - -SYMBOL: max-registers - -SYMBOL: max-insns - -SYMBOL: max-uses - -: not-taken ( -- n ) - available get keys dup empty? [ "Oops" throw ] when - random - dup taken get nth 1 + max-registers get = [ - dup available get delete-at - ] [ - dup taken get [ 1 + ] change-nth - ] if ; - -: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq ) - [ - max-insns set - max-registers set - max-uses set - max-insns get [ 0 ] replicate taken set - max-insns get [ dup ] H{ } map>assoc available set - [ - \ live-interval new - swap int-regs swap vreg boa >>vreg - max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort - [ >>uses ] [ first >>start ] bi - dup uses>> last >>end - dup [ start>> ] [ end>> ] bi 1vector >>ranges - ] map - ] with-scope ; - -: random-test ( num-intervals max-uses max-registers max-insns -- ) - over [ random-live-intervals ] dip int-regs associate check-linear-scan ; - -[ ] [ 30 2 1 60 random-test ] unit-test -[ ] [ 60 2 2 60 random-test ] unit-test -[ ] [ 80 2 3 200 random-test ] unit-test -[ ] [ 70 2 5 30 random-test ] unit-test -[ ] [ 60 2 6 30 random-test ] unit-test -[ ] [ 1 2 10 10 random-test ] unit-test - -[ ] [ 10 4 2 60 random-test ] unit-test -[ ] [ 10 20 2 400 random-test ] unit-test -[ ] [ 10 20 4 300 random-test ] unit-test - -USING: math.private ; - -[ ] [ - [ float+ float>fixnum 3 fixnum*fast ] - test-cfg first optimize-cfg linear-scan drop -] unit-test - -: fake-live-ranges ( seq -- seq' ) - [ - clone dup [ start>> ] [ end>> ] bi 1vector >>ranges - ] map ; - -! Coalescing interacted badly with splitting -[ ] [ - { - T{ live-interval - { vreg V int-regs 70 } - { start 14 } - { end 17 } - { uses V{ 14 15 16 17 } } - { copy-from V int-regs 67 } - } - T{ live-interval - { vreg V int-regs 67 } - { start 13 } - { end 14 } - { uses V{ 13 14 } } - } - T{ live-interval - { vreg V int-regs 30 } - { start 4 } - { end 18 } - { uses V{ 4 12 16 17 18 } } - } - T{ live-interval - { vreg V int-regs 27 } - { start 3 } - { end 13 } - { uses V{ 3 7 13 } } - } - T{ live-interval - { vreg V int-regs 59 } - { start 10 } - { end 18 } - { uses V{ 10 11 12 18 } } - { copy-from V int-regs 56 } - } - T{ live-interval - { vreg V int-regs 60 } - { start 12 } - { end 17 } - { uses V{ 12 17 } } - } - T{ live-interval - { vreg V int-regs 56 } - { start 9 } - { end 10 } - { uses V{ 9 10 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 } } } - allocate-registers drop -] unit-test - -[ ] [ - { - T{ live-interval - { vreg V int-regs 3687168 } - { start 106 } - { end 112 } - { uses V{ 106 112 } } - } - T{ live-interval - { vreg V int-regs 3687169 } - { start 107 } - { end 113 } - { uses V{ 107 113 } } - } - T{ live-interval - { vreg V int-regs 3687727 } - { start 190 } - { end 198 } - { uses V{ 190 195 198 } } - } - T{ live-interval - { vreg V int-regs 3686445 } - { start 43 } - { end 44 } - { uses V{ 43 44 } } - } - T{ live-interval - { vreg V int-regs 3686195 } - { start 5 } - { end 11 } - { uses V{ 5 11 } } - } - T{ live-interval - { vreg V int-regs 3686449 } - { start 44 } - { end 56 } - { uses V{ 44 45 45 46 56 } } - { copy-from V int-regs 3686445 } - } - T{ live-interval - { vreg V int-regs 3686198 } - { start 8 } - { end 10 } - { uses V{ 8 9 10 } } - } - T{ live-interval - { vreg V int-regs 3686454 } - { start 46 } - { end 49 } - { uses V{ 46 47 47 49 } } - { copy-from V int-regs 3686449 } - } - T{ live-interval - { vreg V int-regs 3686196 } - { start 6 } - { end 12 } - { uses V{ 6 12 } } - } - T{ live-interval - { vreg V int-regs 3686197 } - { start 7 } - { end 14 } - { uses V{ 7 13 14 } } - } - T{ live-interval - { vreg V int-regs 3686455 } - { start 48 } - { end 51 } - { uses V{ 48 51 } } - } - T{ live-interval - { vreg V int-regs 3686463 } - { start 52 } - { end 53 } - { uses V{ 52 53 } } - } - T{ live-interval - { vreg V int-regs 3686460 } - { start 49 } - { end 52 } - { uses V{ 49 50 50 52 } } - { copy-from V int-regs 3686454 } - } - T{ live-interval - { vreg V int-regs 3686461 } - { start 51 } - { end 71 } - { uses V{ 51 52 64 68 71 } } - } - T{ live-interval - { vreg V int-regs 3686464 } - { start 53 } - { end 54 } - { uses V{ 53 54 } } - } - T{ live-interval - { vreg V int-regs 3686465 } - { start 54 } - { end 76 } - { uses V{ 54 55 55 76 } } - { copy-from V int-regs 3686464 } - } - T{ live-interval - { vreg V int-regs 3686470 } - { start 58 } - { end 60 } - { uses V{ 58 59 59 60 } } - { copy-from V int-regs 3686469 } - } - T{ live-interval - { vreg V int-regs 3686469 } - { start 56 } - { end 58 } - { uses V{ 56 57 57 58 } } - { copy-from V int-regs 3686449 } - } - T{ live-interval - { vreg V int-regs 3686473 } - { start 60 } - { end 62 } - { uses V{ 60 61 61 62 } } - { copy-from V int-regs 3686470 } - } - T{ live-interval - { vreg V int-regs 3686479 } - { start 62 } - { end 64 } - { uses V{ 62 63 63 64 } } - { copy-from V int-regs 3686473 } - } - T{ live-interval - { vreg V int-regs 3686735 } - { start 78 } - { end 96 } - { uses V{ 78 79 79 96 } } - { copy-from V int-regs 3686372 } - } - T{ live-interval - { vreg V int-regs 3686482 } - { start 64 } - { end 65 } - { uses V{ 64 65 } } - } - T{ live-interval - { vreg V int-regs 3686483 } - { start 65 } - { end 66 } - { uses V{ 65 66 } } - } - T{ live-interval - { vreg V int-regs 3687510 } - { start 168 } - { end 171 } - { uses V{ 168 171 } } - } - T{ live-interval - { vreg V int-regs 3687511 } - { start 169 } - { end 176 } - { uses V{ 169 176 } } - } - T{ live-interval - { vreg V int-regs 3686484 } - { start 66 } - { end 75 } - { uses V{ 66 67 67 75 } } - { copy-from V int-regs 3686483 } - } - T{ live-interval - { vreg V int-regs 3687509 } - { start 162 } - { end 163 } - { uses V{ 162 163 } } - } - T{ live-interval - { vreg V int-regs 3686491 } - { start 68 } - { end 69 } - { uses V{ 68 69 } } - } - T{ live-interval - { vreg V int-regs 3687512 } - { start 170 } - { end 178 } - { uses V{ 170 177 178 } } - } - T{ live-interval - { vreg V int-regs 3687515 } - { start 172 } - { end 173 } - { uses V{ 172 173 } } - } - T{ live-interval - { vreg V int-regs 3686492 } - { start 69 } - { end 74 } - { uses V{ 69 70 70 74 } } - { copy-from V int-regs 3686491 } - } - T{ live-interval - { vreg V int-regs 3687778 } - { start 202 } - { end 208 } - { uses V{ 202 208 } } - } - T{ live-interval - { vreg V int-regs 3686499 } - { start 71 } - { end 72 } - { uses V{ 71 72 } } - } - T{ live-interval - { vreg V int-regs 3687520 } - { start 174 } - { end 175 } - { uses V{ 174 175 } } - } - T{ live-interval - { vreg V int-regs 3687779 } - { start 203 } - { end 209 } - { uses V{ 203 209 } } - } - T{ live-interval - { vreg V int-regs 3687782 } - { start 206 } - { end 207 } - { uses V{ 206 207 } } - } - T{ live-interval - { vreg V int-regs 3686503 } - { start 74 } - { end 75 } - { uses V{ 74 75 } } - } - T{ live-interval - { vreg V int-regs 3686500 } - { start 72 } - { end 74 } - { uses V{ 72 73 73 74 } } - { copy-from V int-regs 3686499 } - } - T{ live-interval - { vreg V int-regs 3687780 } - { start 204 } - { end 210 } - { uses V{ 204 210 } } - } - T{ live-interval - { vreg V int-regs 3686506 } - { start 75 } - { end 76 } - { uses V{ 75 76 } } - } - T{ live-interval - { vreg V int-regs 3687530 } - { start 185 } - { end 192 } - { uses V{ 185 192 } } - } - T{ live-interval - { vreg V int-regs 3687528 } - { start 183 } - { end 198 } - { uses V{ 183 198 } } - } - T{ live-interval - { vreg V int-regs 3687529 } - { start 184 } - { end 197 } - { uses V{ 184 197 } } - } - T{ live-interval - { vreg V int-regs 3687781 } - { start 205 } - { end 211 } - { uses V{ 205 211 } } - } - T{ live-interval - { vreg V int-regs 3687535 } - { start 187 } - { end 194 } - { uses V{ 187 194 } } - } - T{ live-interval - { vreg V int-regs 3686252 } - { start 9 } - { end 17 } - { uses V{ 9 15 17 } } - } - T{ live-interval - { vreg V int-regs 3686509 } - { start 76 } - { end 90 } - { uses V{ 76 87 90 } } - } - T{ live-interval - { vreg V int-regs 3687532 } - { start 186 } - { end 196 } - { uses V{ 186 196 } } - } - T{ live-interval - { vreg V int-regs 3687538 } - { start 188 } - { end 193 } - { uses V{ 188 193 } } - } - T{ live-interval - { vreg V int-regs 3687827 } - { start 217 } - { end 219 } - { uses V{ 217 219 } } - } - T{ live-interval - { vreg V int-regs 3687825 } - { start 215 } - { end 218 } - { uses V{ 215 216 218 } } - } - T{ live-interval - { vreg V int-regs 3687831 } - { start 218 } - { end 219 } - { uses V{ 218 219 } } - } - T{ live-interval - { vreg V int-regs 3686296 } - { start 16 } - { end 18 } - { uses V{ 16 18 } } - } - T{ live-interval - { vreg V int-regs 3686302 } - { start 29 } - { end 31 } - { uses V{ 29 31 } } - } - T{ live-interval - { vreg V int-regs 3687838 } - { start 231 } - { end 232 } - { uses V{ 231 232 } } - } - T{ live-interval - { vreg V int-regs 3686300 } - { start 26 } - { end 27 } - { uses V{ 26 27 } } - } - T{ live-interval - { vreg V int-regs 3686301 } - { start 27 } - { end 30 } - { uses V{ 27 28 28 30 } } - { copy-from V int-regs 3686300 } - } - T{ live-interval - { vreg V int-regs 3686306 } - { start 37 } - { end 93 } - { uses V{ 37 82 93 } } - } - T{ live-interval - { vreg V int-regs 3686307 } - { start 38 } - { end 88 } - { uses V{ 38 85 88 } } - } - T{ live-interval - { vreg V int-regs 3687837 } - { start 222 } - { end 223 } - { uses V{ 222 223 } } - } - T{ live-interval - { vreg V int-regs 3686305 } - { start 36 } - { end 81 } - { uses V{ 36 42 77 81 } } - } - T{ live-interval - { vreg V int-regs 3686310 } - { start 39 } - { end 95 } - { uses V{ 39 84 95 } } - } - T{ live-interval - { vreg V int-regs 3687836 } - { start 227 } - { end 228 } - { uses V{ 227 228 } } - } - T{ live-interval - { vreg V int-regs 3687839 } - { start 239 } - { end 246 } - { uses V{ 239 245 246 } } - } - T{ live-interval - { vreg V int-regs 3687841 } - { start 240 } - { end 241 } - { uses V{ 240 241 } } - } - T{ live-interval - { vreg V int-regs 3687845 } - { start 241 } - { end 243 } - { uses V{ 241 243 } } - } - T{ live-interval - { vreg V int-regs 3686315 } - { start 40 } - { end 94 } - { uses V{ 40 83 94 } } - } - T{ live-interval - { vreg V int-regs 3687846 } - { start 242 } - { end 245 } - { uses V{ 242 245 } } - } - T{ live-interval - { vreg V int-regs 3687849 } - { start 243 } - { end 245 } - { uses V{ 243 244 244 245 } } - { copy-from V int-regs 3687845 } - } - T{ live-interval - { vreg V int-regs 3687850 } - { start 245 } - { end 245 } - { uses V{ 245 } } - } - T{ live-interval - { vreg V int-regs 3687851 } - { start 246 } - { end 246 } - { uses V{ 246 } } - } - T{ live-interval - { vreg V int-regs 3687852 } - { start 246 } - { end 246 } - { uses V{ 246 } } - } - T{ live-interval - { vreg V int-regs 3687853 } - { start 247 } - { end 248 } - { uses V{ 247 248 } } - } - T{ live-interval - { vreg V int-regs 3687854 } - { start 249 } - { end 250 } - { uses V{ 249 250 } } - } - T{ live-interval - { vreg V int-regs 3687855 } - { start 258 } - { end 259 } - { uses V{ 258 259 } } - } - T{ live-interval - { vreg V int-regs 3687080 } - { start 280 } - { end 285 } - { uses V{ 280 285 } } - } - T{ live-interval - { vreg V int-regs 3687081 } - { start 281 } - { end 286 } - { uses V{ 281 286 } } - } - T{ live-interval - { vreg V int-regs 3687082 } - { start 282 } - { end 287 } - { uses V{ 282 287 } } - } - T{ live-interval - { vreg V int-regs 3687083 } - { start 283 } - { end 288 } - { uses V{ 283 288 } } - } - T{ live-interval - { vreg V int-regs 3687085 } - { start 284 } - { end 299 } - { uses V{ 284 285 286 287 288 296 299 } } - } - T{ live-interval - { vreg V int-regs 3687086 } - { start 284 } - { end 284 } - { uses V{ 284 } } - } - T{ live-interval - { vreg V int-regs 3687087 } - { start 289 } - { end 293 } - { uses V{ 289 293 } } - } - T{ live-interval - { vreg V int-regs 3687088 } - { start 290 } - { end 294 } - { uses V{ 290 294 } } - } - T{ live-interval - { vreg V int-regs 3687089 } - { start 291 } - { end 297 } - { uses V{ 291 297 } } - } - T{ live-interval - { vreg V int-regs 3687090 } - { start 292 } - { end 298 } - { uses V{ 292 298 } } - } - T{ live-interval - { vreg V int-regs 3687363 } - { start 118 } - { end 119 } - { uses V{ 118 119 } } - } - T{ live-interval - { vreg V int-regs 3686599 } - { start 77 } - { end 89 } - { uses V{ 77 86 89 } } - } - T{ live-interval - { vreg V int-regs 3687370 } - { start 131 } - { end 132 } - { uses V{ 131 132 } } - } - T{ live-interval - { vreg V int-regs 3687371 } - { start 138 } - { end 143 } - { uses V{ 138 143 } } - } - T{ live-interval - { vreg V int-regs 3687368 } - { start 127 } - { end 128 } - { uses V{ 127 128 } } - } - T{ live-interval - { vreg V int-regs 3687369 } - { start 122 } - { end 123 } - { uses V{ 122 123 } } - } - T{ live-interval - { vreg V int-regs 3687373 } - { start 139 } - { end 140 } - { uses V{ 139 140 } } - } - T{ live-interval - { vreg V int-regs 3686352 } - { start 41 } - { end 91 } - { uses V{ 41 43 79 91 } } - } - T{ live-interval - { vreg V int-regs 3687377 } - { start 140 } - { end 141 } - { uses V{ 140 141 } } - } - T{ live-interval - { vreg V int-regs 3687382 } - { start 143 } - { end 143 } - { uses V{ 143 } } - } - T{ live-interval - { vreg V int-regs 3687383 } - { start 144 } - { end 161 } - { uses V{ 144 159 161 } } - } - T{ live-interval - { vreg V int-regs 3687380 } - { start 141 } - { end 143 } - { uses V{ 141 142 142 143 } } - { copy-from V int-regs 3687377 } - } - T{ live-interval - { vreg V int-regs 3687381 } - { start 143 } - { end 160 } - { uses V{ 143 160 } } - } - T{ live-interval - { vreg V int-regs 3687384 } - { start 145 } - { end 158 } - { uses V{ 145 158 } } - } - T{ live-interval - { vreg V int-regs 3687385 } - { start 146 } - { end 157 } - { uses V{ 146 157 } } - } - T{ live-interval - { vreg V int-regs 3687640 } - { start 189 } - { end 191 } - { uses V{ 189 191 } } - } - T{ live-interval - { vreg V int-regs 3687388 } - { start 147 } - { end 152 } - { uses V{ 147 152 } } - } - T{ live-interval - { vreg V int-regs 3687393 } - { start 148 } - { end 153 } - { uses V{ 148 153 } } - } - T{ live-interval - { vreg V int-regs 3687398 } - { start 149 } - { end 154 } - { uses V{ 149 154 } } - } - T{ live-interval - { vreg V int-regs 3686372 } - { start 42 } - { end 92 } - { uses V{ 42 45 78 80 92 } } - } - T{ live-interval - { vreg V int-regs 3687140 } - { start 293 } - { end 295 } - { uses V{ 293 294 294 295 } } - { copy-from V int-regs 3687087 } - } - T{ live-interval - { vreg V int-regs 3687403 } - { start 150 } - { end 155 } - { uses V{ 150 155 } } - } - T{ live-interval - { vreg V int-regs 3687150 } - { start 304 } - { end 306 } - { uses V{ 304 306 } } - } - T{ live-interval - { vreg V int-regs 3687151 } - { start 305 } - { end 307 } - { uses V{ 305 307 } } - } - T{ live-interval - { vreg V int-regs 3687408 } - { start 151 } - { end 156 } - { uses V{ 151 156 } } - } - T{ live-interval - { vreg V int-regs 3687153 } - { start 312 } - { end 313 } - { uses V{ 312 313 } } - } - T{ live-interval - { vreg V int-regs 3686902 } - { start 267 } - { end 272 } - { uses V{ 267 272 } } - } - T{ live-interval - { vreg V int-regs 3686903 } - { start 268 } - { end 273 } - { uses V{ 268 273 } } - } - T{ live-interval - { vreg V int-regs 3686900 } - { start 265 } - { end 270 } - { uses V{ 265 270 } } - } - T{ live-interval - { vreg V int-regs 3686901 } - { start 266 } - { end 271 } - { uses V{ 266 271 } } - } - T{ live-interval - { vreg V int-regs 3687162 } - { start 100 } - { end 119 } - { uses V{ 100 114 117 119 } } - } - T{ live-interval - { vreg V int-regs 3687163 } - { start 101 } - { end 118 } - { uses V{ 101 115 116 118 } } - } - T{ live-interval - { vreg V int-regs 3686904 } - { start 269 } - { end 274 } - { uses V{ 269 274 } } - } - T{ live-interval - { vreg V int-regs 3687166 } - { start 104 } - { end 110 } - { uses V{ 104 110 } } - } - T{ live-interval - { vreg V int-regs 3687167 } - { start 105 } - { end 111 } - { uses V{ 105 111 } } - } - T{ live-interval - { vreg V int-regs 3687164 } - { start 102 } - { end 108 } - { uses V{ 102 108 } } - } - T{ live-interval - { vreg V int-regs 3687165 } - { start 103 } - { end 109 } - { uses V{ 103 109 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 4 } } } - allocate-registers drop -] unit-test - -! A reduction of the above -[ ] [ - { - T{ live-interval - { vreg V int-regs 6449 } - { start 44 } - { end 56 } - { uses V{ 44 45 46 56 } } - } - T{ live-interval - { vreg V int-regs 6454 } - { start 46 } - { end 49 } - { uses V{ 46 47 49 } } - } - T{ live-interval - { vreg V int-regs 6455 } - { start 48 } - { end 51 } - { uses V{ 48 51 } } - } - T{ live-interval - { vreg V int-regs 6460 } - { start 49 } - { end 52 } - { uses V{ 49 50 52 } } - } - T{ live-interval - { vreg V int-regs 6461 } - { start 51 } - { end 71 } - { uses V{ 51 52 64 68 71 } } - } - T{ live-interval - { vreg V int-regs 6464 } - { start 53 } - { end 54 } - { uses V{ 53 54 } } - } - T{ live-interval - { vreg V int-regs 6470 } - { start 58 } - { end 60 } - { uses V{ 58 59 60 } } - } - T{ live-interval - { vreg V int-regs 6469 } - { start 56 } - { end 58 } - { uses V{ 56 57 58 } } - } - T{ live-interval - { vreg V int-regs 6473 } - { start 60 } - { end 62 } - { uses V{ 60 61 62 } } - } - T{ live-interval - { vreg V int-regs 6479 } - { start 62 } - { end 64 } - { uses V{ 62 63 64 } } - } - T{ live-interval - { vreg V int-regs 6735 } - { start 78 } - { end 96 } - { uses V{ 78 79 96 } } - { copy-from V int-regs 6372 } - } - T{ live-interval - { vreg V int-regs 6483 } - { start 65 } - { end 66 } - { uses V{ 65 66 } } - } - T{ live-interval - { vreg V int-regs 7845 } - { start 91 } - { end 93 } - { uses V{ 91 93 } } - } - T{ live-interval - { vreg V int-regs 6372 } - { start 42 } - { end 92 } - { uses V{ 42 45 78 80 92 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 } } } - allocate-registers drop -] unit-test - [ f ] [ T{ live-range f 0 10 } T{ live-range f 20 30 } @@ -1446,13 +505,20 @@ USING: math.private ; ! register-status had problems because it used map>assoc where the sequence ! had multiple keys +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + { 4 int-rep } +} representations set + [ { 0 10 } ] [ H{ { int-regs { 0 1 } } } registers set H{ { int-regs { T{ live-interval - { vreg V int-regs 1 } + { vreg 1 } { start 0 } { end 20 } { reg 0 } @@ -1461,7 +527,7 @@ USING: math.private ; } T{ live-interval - { vreg V int-regs 2 } + { vreg 2 } { start 4 } { end 40 } { reg 0 } @@ -1475,7 +541,7 @@ USING: math.private ; { int-regs { T{ live-interval - { vreg V int-regs 3 } + { vreg 3 } { start 0 } { end 40 } { reg 1 } @@ -1487,7 +553,7 @@ USING: math.private ; } active-intervals set T{ live-interval - { vreg V int-regs 4 } + { vreg 4 } { start 8 } { end 10 } { ranges V{ T{ live-range f 8 10 } } } @@ -1496,29 +562,38 @@ USING: math.private ; register-status ] unit-test +:: test-linear-scan-on-cfg ( regs -- ) + [ + cfg new 0 get >>entry + dup cfg set + dup fake-representations + dup { { int-regs regs } } (linear-scan) + flatten-cfg 1array mr. + ] with-scope ; + ! Bug in live spill slots calculation V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ T{ ##peek - { dst V int-regs 703128 } + { dst 703128 } { loc D 1 } } T{ ##peek - { dst V int-regs 703129 } + { dst 703129 } { loc D 0 } } T{ ##copy - { dst V int-regs 703134 } - { src V int-regs 703128 } + { dst 703134 } + { src 703128 } } T{ ##copy - { dst V int-regs 703135 } - { src V int-regs 703129 } + { dst 703135 } + { src 703129 } } T{ ##compare-imm-branch - { src1 V int-regs 703128 } + { src1 703128 } { src2 5 } { cc cc/= } } @@ -1526,23 +601,23 @@ V{ V{ T{ ##copy - { dst V int-regs 703134 } - { src V int-regs 703129 } + { dst 703134 } + { src 703129 } } T{ ##copy - { dst V int-regs 703135 } - { src V int-regs 703128 } + { dst 703135 } + { src 703128 } } T{ ##branch } } 2 test-bb V{ T{ ##replace - { src V int-regs 703134 } + { src 703134 } { loc D 0 } } T{ ##replace - { src V int-regs 703135 } + { src 703135 } { loc D 1 } } T{ ##epilogue } @@ -1553,38 +628,25 @@ V{ 1 { 2 3 } edges 2 3 edge -SYMBOL: linear-scan-result - -:: test-linear-scan-on-cfg ( regs -- ) - [ - cfg new 0 get >>entry - compute-predecessors - dup { { int-regs regs } } (linear-scan) - cfg-changed - flatten-cfg 1array mr. - ] with-scope ; - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - ! Bug in inactive interval handling ! [ rot dup [ -rot ] when ] V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ T{ ##peek - { dst V int-regs 689473 } + { dst 689473 } { loc D 2 } } T{ ##peek - { dst V int-regs 689474 } + { dst 689474 } { loc D 1 } } T{ ##peek - { dst V int-regs 689475 } + { dst 689475 } { loc D 0 } } T{ ##compare-imm-branch - { src1 V int-regs 689473 } + { src1 689473 } { src2 5 } { cc cc/= } } @@ -1592,47 +654,47 @@ V{ V{ T{ ##copy - { dst V int-regs 689481 } - { src V int-regs 689475 } + { dst 689481 } + { src 689475 } } T{ ##copy - { dst V int-regs 689482 } - { src V int-regs 689474 } + { dst 689482 } + { src 689474 } } T{ ##copy - { dst V int-regs 689483 } - { src V int-regs 689473 } + { dst 689483 } + { src 689473 } } T{ ##branch } } 2 test-bb V{ T{ ##copy - { dst V int-regs 689481 } - { src V int-regs 689473 } + { dst 689481 } + { src 689473 } } T{ ##copy - { dst V int-regs 689482 } - { src V int-regs 689475 } + { dst 689482 } + { src 689475 } } T{ ##copy - { dst V int-regs 689483 } - { src V int-regs 689474 } + { dst 689483 } + { src 689474 } } T{ ##branch } } 3 test-bb V{ T{ ##replace - { src V int-regs 689481 } + { src 689481 } { loc D 0 } } T{ ##replace - { src V int-regs 689482 } + { src 689482 } { loc D 1 } } T{ ##replace - { src V int-regs 689483 } + { src 689483 } { loc D 2 } } T{ ##epilogue } @@ -1654,15 +716,15 @@ T{ basic-block V{ T{ ##peek - { dst V int-regs 689600 } + { dst 689600 } { loc D 1 } } T{ ##peek - { dst V int-regs 689601 } + { dst 689601 } { loc D 0 } } T{ ##compare-imm-branch - { src1 V int-regs 689600 } + { src1 689600 } { src2 5 } { cc cc/= } } @@ -1670,55 +732,55 @@ V{ V{ T{ ##peek - { dst V int-regs 689604 } + { dst 689604 } { loc D 2 } } T{ ##copy - { dst V int-regs 689607 } - { src V int-regs 689604 } + { dst 689607 } + { src 689604 } } T{ ##copy - { dst V int-regs 689608 } - { src V int-regs 689600 } + { dst 689608 } + { src 689600 } } T{ ##copy - { dst V int-regs 689610 } - { src V int-regs 689601 } + { dst 689610 } + { src 689601 } } T{ ##branch } } 2 test-bb V{ T{ ##peek - { dst V int-regs 689609 } + { dst 689609 } { loc D 2 } } T{ ##copy - { dst V int-regs 689607 } - { src V int-regs 689600 } + { dst 689607 } + { src 689600 } } T{ ##copy - { dst V int-regs 689608 } - { src V int-regs 689601 } + { dst 689608 } + { src 689601 } } T{ ##copy - { dst V int-regs 689610 } - { src V int-regs 689609 } + { dst 689610 } + { src 689609 } } T{ ##branch } } 3 test-bb V{ T{ ##replace - { src V int-regs 689607 } + { src 689607 } { loc D 0 } } T{ ##replace - { src V int-regs 689608 } + { src 689608 } { loc D 1 } } T{ ##replace - { src V int-regs 689610 } + { src 689610 } { loc D 2 } } T{ ##epilogue } @@ -1736,11 +798,11 @@ V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ T{ ##peek - { dst V int-regs 0 } + { dst 0 } { loc D 0 } } T{ ##compare-imm-branch - { src1 V int-regs 0 } + { src1 0 } { src2 5 } { cc cc/= } } @@ -1748,31 +810,31 @@ V{ V{ T{ ##peek - { dst V int-regs 1 } + { dst 1 } { loc D 1 } } T{ ##copy - { dst V int-regs 2 } - { src V int-regs 1 } + { dst 2 } + { src 1 } } T{ ##branch } } 2 test-bb V{ T{ ##peek - { dst V int-regs 3 } + { dst 3 } { loc D 2 } } T{ ##copy - { dst V int-regs 2 } - { src V int-regs 3 } + { dst 2 } + { src 3 } } T{ ##branch } } 3 test-bb V{ T{ ##replace - { src V int-regs 2 } + { src 2 } { loc D 0 } } T{ ##return } @@ -1785,29 +847,29 @@ test-diamond ! Inactive interval handling: splitting active interval ! if it fits in lifetime hole only partially -V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb +V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 2 R 0 } - T{ ##compare-imm-branch f V int-regs 2 5 cc= } + T{ ##peek f 2 R 0 } + T{ ##compare-imm-branch f 2 5 cc= } } 1 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 2 test-bb V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 2 } + T{ ##peek f 1 D 1 } + T{ ##peek f 0 D 0 } + T{ ##replace f 1 D 2 } T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 3 R 2 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 3 R 2 } + T{ ##replace f 0 D 0 } T{ ##return } } 4 test-bb @@ -1819,11 +881,11 @@ test-diamond ! [ _copy ] [ 3 get instructions>> second class ] unit-test ! Resolve pass; make sure the spilling is done correctly -V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb +V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 2 R 0 } - T{ ##compare-imm-branch f V int-regs 2 5 cc= } + T{ ##peek f 2 R 0 } + T{ ##compare-imm-branch f 2 5 cc= } } 1 test-bb V{ @@ -1831,16 +893,16 @@ V{ } 2 test-bb V{ - T{ ##replace f V int-regs 3 R 1 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##replace f V int-regs 0 D 2 } + T{ ##replace f 3 R 1 } + T{ ##peek f 1 D 1 } + T{ ##peek f 0 D 0 } + T{ ##replace f 1 D 2 } + T{ ##replace f 0 D 2 } T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 3 R 2 } + T{ ##replace f 3 R 2 } T{ ##return } } 4 test-bb @@ -1862,16 +924,16 @@ V{ } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-imm-branch f V int-regs 0 5 cc= } + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } } 1 test-bb V{ - T{ ##replace 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{ ##replace f V int-regs 1 D 0 } - T{ ##replace f V int-regs 2 D 0 } + T{ ##replace f 0 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } T{ ##branch } } 2 test-bb @@ -1880,17 +942,17 @@ V{ } 3 test-bb V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##compare-imm-branch f V int-regs 1 5 cc= } + T{ ##peek f 1 D 0 } + T{ ##compare-imm-branch f 1 5 cc= } } 4 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 5 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 6 test-bb @@ -1912,45 +974,45 @@ V{ ! got fixed V{ T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##peek f V int-regs 3 D 3 } - T{ ##peek f V int-regs 4 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##peek f 3 D 3 } + T{ ##peek f 4 D 0 } T{ ##branch } } 1 test-bb V{ T{ ##branch } } 2 test-bb V{ T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##replace f V int-regs 3 D 3 } - T{ ##replace f V int-regs 4 D 4 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##replace f 4 D 4 } + T{ ##replace f 0 D 0 } T{ ##branch } } 4 test-bb -V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb +V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb V{ T{ ##return } } 6 test-bb V{ T{ ##branch } } 7 test-bb V{ - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##replace f V int-regs 3 D 3 } - T{ ##peek f V int-regs 5 D 1 } - T{ ##peek f V int-regs 6 D 2 } - T{ ##peek f V int-regs 7 D 3 } - T{ ##peek f V int-regs 8 D 4 } - T{ ##replace f V int-regs 5 D 1 } - T{ ##replace f V int-regs 6 D 2 } - T{ ##replace f V int-regs 7 D 3 } - T{ ##replace f V int-regs 8 D 4 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##peek f 5 D 1 } + T{ ##peek f 6 D 2 } + T{ ##peek f 7 D 3 } + T{ ##peek f 8 D 4 } + T{ ##replace f 5 D 1 } + T{ ##replace f 6 D 2 } + T{ ##replace f 7 D 3 } + T{ ##replace f 8 D 4 } T{ ##branch } } 8 test-bb V{ - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##replace f V int-regs 3 D 3 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } T{ ##return } } 9 test-bb @@ -1967,32 +1029,32 @@ V{ [ _spill ] [ 1 get instructions>> second class ] unit-test [ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test -[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test -[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test +[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test ! Resolve pass should insert this [ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test ! Some random bug V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##peek f 3 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 test-bb V{ T{ ##branch } } 1 test-bb V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##replace f V int-regs 3 D 3 } - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##replace f V int-regs 0 D 3 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 0 D 3 } T{ ##branch } } 2 test-bb @@ -2009,40 +1071,40 @@ test-diamond ! Spilling an interval immediately after its activated; ! and the interval does not have a use at the activation point V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##replace f V int-regs 1 D 1 } - T{ ##replace f V int-regs 2 D 2 } - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 test-bb V{ T{ ##branch } } 1 test-bb V{ - T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f 1 D 1 } T{ ##branch } } 2 test-bb V{ - T{ ##replace f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##replace f V int-regs 2 D 2 } + T{ ##replace f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 2 D 2 } T{ ##branch } } 3 test-bb V{ T{ ##branch } } 4 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 5 test-bb -1 get 1vector 0 get (>>successors) -2 get 4 get V{ } 2sequence 1 get (>>successors) -5 get 1vector 4 get (>>successors) -3 get 1vector 2 get (>>successors) -5 get 1vector 3 get (>>successors) +0 1 edge +1 { 2 4 } edges +4 5 edge +2 3 edge +3 5 edge [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test @@ -2050,89 +1112,89 @@ V{ V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ - T{ ##load-immediate { dst V int-regs 61 } } - T{ ##peek { dst V int-regs 62 } { loc D 0 } } - T{ ##peek { dst V int-regs 64 } { loc D 1 } } + T{ ##load-immediate { dst 61 } } + T{ ##peek { dst 62 } { loc D 0 } } + T{ ##peek { dst 64 } { loc D 1 } } T{ ##slot-imm - { dst V int-regs 69 } - { obj V int-regs 64 } + { dst 69 } + { obj 64 } { slot 1 } { tag 2 } } - T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } } + T{ ##copy { dst 79 } { src 69 } } T{ ##slot-imm - { dst V int-regs 85 } - { obj V int-regs 62 } + { dst 85 } + { obj 62 } { slot 2 } { tag 7 } } T{ ##compare-branch - { src1 V int-regs 69 } - { src2 V int-regs 85 } + { src1 69 } + { src2 85 } { cc cc> } } } 1 test-bb V{ T{ ##slot-imm - { dst V int-regs 97 } - { obj V int-regs 62 } + { dst 97 } + { obj 62 } { slot 2 } { tag 7 } } - T{ ##replace { src V int-regs 79 } { loc D 3 } } - T{ ##replace { src V int-regs 62 } { loc D 4 } } - T{ ##replace { src V int-regs 79 } { loc D 1 } } - T{ ##replace { src V int-regs 62 } { loc D 2 } } - T{ ##replace { src V int-regs 61 } { loc D 5 } } - T{ ##replace { src V int-regs 62 } { loc R 0 } } - T{ ##replace { src V int-regs 69 } { loc R 1 } } - T{ ##replace { src V int-regs 97 } { loc D 0 } } + T{ ##replace { src 79 } { loc D 3 } } + T{ ##replace { src 62 } { loc D 4 } } + T{ ##replace { src 79 } { loc D 1 } } + T{ ##replace { src 62 } { loc D 2 } } + T{ ##replace { src 61 } { loc D 5 } } + T{ ##replace { src 62 } { loc R 0 } } + T{ ##replace { src 69 } { loc R 1 } } + T{ ##replace { src 97 } { loc D 0 } } T{ ##call { word resize-array } } T{ ##branch } } 2 test-bb V{ - T{ ##peek { dst V int-regs 98 } { loc R 0 } } - T{ ##peek { dst V int-regs 100 } { loc D 0 } } + T{ ##peek { dst 98 } { loc R 0 } } + T{ ##peek { dst 100 } { loc D 0 } } T{ ##set-slot-imm - { src V int-regs 100 } - { obj V int-regs 98 } + { src 100 } + { obj 98 } { slot 2 } { tag 7 } } - T{ ##peek { dst V int-regs 108 } { loc D 2 } } - T{ ##peek { dst V int-regs 110 } { loc D 3 } } - T{ ##peek { dst V int-regs 112 } { loc D 0 } } - T{ ##peek { dst V int-regs 114 } { loc D 1 } } - T{ ##peek { dst V int-regs 116 } { loc D 4 } } - T{ ##peek { dst V int-regs 119 } { loc R 0 } } - T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } } - T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } } - T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } } - T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } } + T{ ##peek { dst 108 } { loc D 2 } } + T{ ##peek { dst 110 } { loc D 3 } } + T{ ##peek { dst 112 } { loc D 0 } } + T{ ##peek { dst 114 } { loc D 1 } } + T{ ##peek { dst 116 } { loc D 4 } } + T{ ##peek { dst 119 } { loc R 0 } } + T{ ##copy { dst 109 } { src 108 } } + T{ ##copy { dst 111 } { src 110 } } + T{ ##copy { dst 113 } { src 112 } } + T{ ##copy { dst 115 } { src 114 } } + T{ ##copy { dst 117 } { src 116 } } + T{ ##copy { dst 120 } { src 119 } } T{ ##branch } } 3 test-bb V{ - T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } } - T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } } - T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } } - T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } } + T{ ##copy { dst 109 } { src 62 } } + T{ ##copy { dst 111 } { src 61 } } + T{ ##copy { dst 113 } { src 62 } } + T{ ##copy { dst 115 } { src 79 } } + T{ ##copy { dst 117 } { src 64 } } + T{ ##copy { dst 120 } { src 69 } } T{ ##branch } } 4 test-bb V{ - T{ ##replace { src V int-regs 120 } { loc D 0 } } - T{ ##replace { src V int-regs 109 } { loc D 3 } } - T{ ##replace { src V int-regs 111 } { loc D 4 } } - T{ ##replace { src V int-regs 113 } { loc D 1 } } - T{ ##replace { src V int-regs 115 } { loc D 2 } } - T{ ##replace { src V int-regs 117 } { loc D 5 } } + T{ ##replace { src 120 } { loc D 0 } } + T{ ##replace { src 109 } { loc D 3 } } + T{ ##replace { src 111 } { loc D 4 } } + T{ ##replace { src 113 } { loc D 1 } } + T{ ##replace { src 115 } { loc D 2 } } + T{ ##replace { src 117 } { loc D 5 } } T{ ##epilogue } T{ ##return } } 5 test-bb @@ -2149,137 +1211,137 @@ V{ V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ - T{ ##peek { dst V int-regs 85 } { loc D 0 } } + T{ ##peek { dst 85 } { loc D 0 } } T{ ##slot-imm - { dst V int-regs 89 } - { obj V int-regs 85 } + { dst 89 } + { obj 85 } { slot 3 } { tag 7 } } - T{ ##peek { dst V int-regs 91 } { loc D 1 } } + T{ ##peek { dst 91 } { loc D 1 } } T{ ##slot-imm - { dst V int-regs 96 } - { obj V int-regs 91 } + { dst 96 } + { obj 91 } { slot 1 } { tag 2 } } T{ ##add - { dst V int-regs 109 } - { src1 V int-regs 89 } - { src2 V int-regs 96 } + { dst 109 } + { src1 89 } + { src2 96 } } T{ ##slot-imm - { dst V int-regs 115 } - { obj V int-regs 85 } + { dst 115 } + { obj 85 } { slot 2 } { tag 7 } } T{ ##slot-imm - { dst V int-regs 118 } - { obj V int-regs 115 } + { dst 118 } + { obj 115 } { slot 1 } { tag 2 } } T{ ##compare-branch - { src1 V int-regs 109 } - { src2 V int-regs 118 } + { src1 109 } + { src2 118 } { cc cc> } } } 1 test-bb V{ T{ ##add-imm - { dst V int-regs 128 } - { src1 V int-regs 109 } + { dst 128 } + { src1 109 } { src2 8 } } - T{ ##load-immediate { dst V int-regs 129 } { val 24 } } + T{ ##load-immediate { dst 129 } { val 24 } } T{ ##inc-d { n 4 } } T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 109 } { loc D 2 } } - T{ ##replace { src V int-regs 85 } { loc D 3 } } - T{ ##replace { src V int-regs 128 } { loc D 0 } } - T{ ##replace { src V int-regs 85 } { loc D 1 } } - T{ ##replace { src V int-regs 89 } { loc D 4 } } - T{ ##replace { src V int-regs 96 } { loc R 0 } } - T{ ##replace { src V int-regs 129 } { loc R 0 } } + T{ ##replace { src 109 } { loc D 2 } } + T{ ##replace { src 85 } { loc D 3 } } + T{ ##replace { src 128 } { loc D 0 } } + T{ ##replace { src 85 } { loc D 1 } } + T{ ##replace { src 89 } { loc D 4 } } + T{ ##replace { src 96 } { loc R 0 } } + T{ ##replace { src 129 } { loc R 0 } } T{ ##branch } } 2 test-bb V{ - T{ ##peek { dst V int-regs 134 } { loc D 1 } } + T{ ##peek { dst 134 } { loc D 1 } } T{ ##slot-imm - { dst V int-regs 140 } - { obj V int-regs 134 } + { dst 140 } + { obj 134 } { slot 2 } { tag 7 } } T{ ##inc-d { n 1 } } T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 140 } { loc D 0 } } - T{ ##replace { src V int-regs 134 } { loc R 0 } } + T{ ##replace { src 140 } { loc D 0 } } + T{ ##replace { src 134 } { loc R 0 } } T{ ##call { word resize-array } } T{ ##branch } } 3 test-bb V{ - T{ ##peek { dst V int-regs 141 } { loc R 0 } } - T{ ##peek { dst V int-regs 143 } { loc D 0 } } + T{ ##peek { dst 141 } { loc R 0 } } + T{ ##peek { dst 143 } { loc D 0 } } T{ ##set-slot-imm - { src V int-regs 143 } - { obj V int-regs 141 } + { src 143 } + { obj 141 } { slot 2 } { tag 7 } } T{ ##write-barrier - { src V int-regs 141 } - { card# V int-regs 145 } - { table V int-regs 146 } + { src 141 } + { card# 145 } + { table 146 } } T{ ##inc-d { n -1 } } T{ ##inc-r { n -1 } } - T{ ##peek { dst V int-regs 156 } { loc D 2 } } - T{ ##peek { dst V int-regs 158 } { loc D 3 } } - T{ ##peek { dst V int-regs 160 } { loc D 0 } } - T{ ##peek { dst V int-regs 162 } { loc D 1 } } - T{ ##peek { dst V int-regs 164 } { loc D 4 } } - T{ ##peek { dst V int-regs 167 } { loc R 0 } } - T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } } - T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } } - T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } } - T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } } - T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } } - T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } } + T{ ##peek { dst 156 } { loc D 2 } } + T{ ##peek { dst 158 } { loc D 3 } } + T{ ##peek { dst 160 } { loc D 0 } } + T{ ##peek { dst 162 } { loc D 1 } } + T{ ##peek { dst 164 } { loc D 4 } } + T{ ##peek { dst 167 } { loc R 0 } } + T{ ##copy { dst 157 } { src 156 } } + T{ ##copy { dst 159 } { src 158 } } + T{ ##copy { dst 161 } { src 160 } } + T{ ##copy { dst 163 } { src 162 } } + T{ ##copy { dst 165 } { src 164 } } + T{ ##copy { dst 168 } { src 167 } } T{ ##branch } } 4 test-bb V{ T{ ##inc-d { n 3 } } T{ ##inc-r { n 1 } } - T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } } - T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } } - T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } } - T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } } - T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } } - T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } } + T{ ##copy { dst 157 } { src 85 } } + T{ ##copy { dst 159 } { src 89 } } + T{ ##copy { dst 161 } { src 85 } } + T{ ##copy { dst 163 } { src 109 } } + T{ ##copy { dst 165 } { src 91 } } + T{ ##copy { dst 168 } { src 96 } } T{ ##branch } } 5 test-bb V{ T{ ##set-slot-imm - { src V int-regs 163 } - { obj V int-regs 161 } + { src 163 } + { obj 161 } { slot 3 } { tag 7 } } T{ ##inc-d { n 1 } } T{ ##inc-r { n -1 } } - T{ ##replace { src V int-regs 168 } { loc D 0 } } - T{ ##replace { src V int-regs 157 } { loc D 3 } } - T{ ##replace { src V int-regs 159 } { loc D 4 } } - T{ ##replace { src V int-regs 161 } { loc D 1 } } - T{ ##replace { src V int-regs 163 } { loc D 2 } } - T{ ##replace { src V int-regs 165 } { loc D 5 } } + T{ ##replace { src 168 } { loc D 0 } } + T{ ##replace { src 157 } { loc D 3 } } + T{ ##replace { src 159 } { loc D 4 } } + T{ ##replace { src 161 } { loc D 1 } } + T{ ##replace { src 163 } { loc D 2 } } + T{ ##replace { src 165 } { loc D 5 } } T{ ##epilogue } T{ ##return } } 6 test-bb @@ -2297,22 +1359,22 @@ V{ V{ T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-imm-branch f V int-regs 0 5 cc= } + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } } 1 test-bb V{ T{ ##branch } } 2 test-bb V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##peek f V int-regs 2 D 0 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##replace f V int-regs 2 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 4 test-bb @@ -2332,16 +1394,16 @@ test-diamond V{ T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-imm-branch f V int-regs 0 5 cc= } + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } } 1 test-bb V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##peek f V int-regs 2 D 0 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##replace f V int-regs 2 D 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } + T{ ##replace f 0 D 0 } T{ ##branch } } 2 test-bb @@ -2350,7 +1412,7 @@ V{ } 3 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 4 test-bb @@ -2368,52 +1430,20 @@ test-diamond [ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test -! GC check tests - -! Spill slot liveness was computed incorrectly, leading to a FEP -! early in bootstrap on x86-32 -[ t ] [ - [ - T{ basic-block - { id 12345 } - { instructions - V{ - T{ ##gc f V int-regs 6 V int-regs 7 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##peek f V int-regs 3 D 3 } - T{ ##peek f V int-regs 4 D 4 } - T{ ##peek f V int-regs 5 D 5 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##replace f V int-regs 2 D 3 } - T{ ##replace f V int-regs 3 D 4 } - T{ ##replace f V int-regs 4 D 5 } - T{ ##replace f V int-regs 5 D 0 } - } - } - } cfg new over >>entry - { { int-regs V{ 0 1 2 3 } } } (linear-scan) - instructions>> first - live-values>> assoc-empty? - ] with-scope -] unit-test - V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##replace f 1 D 1 } T{ ##branch } } 0 test-bb V{ - T{ ##gc f V int-regs 2 V int-regs 3 } + T{ ##gc f 2 3 } T{ ##branch } } 1 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##return } } 2 test-bb @@ -2422,19 +1452,17 @@ V{ [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test -[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test - - +[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##compare-imm-branch f V int-regs 1 5 cc= } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##compare-imm-branch f 1 5 cc= } } 0 test-bb V{ - T{ ##gc f V int-regs 2 V int-regs 3 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##gc f 2 3 } + T{ ##replace f 0 D 0 } T{ ##return } } 1 test-bb @@ -2446,4 +1474,4 @@ V{ [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test -[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test +[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 51b2f6db1b..5e723f098a 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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) ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 48bef197e6..2301d26f80 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 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 + [ compute-live-intervals-step ] each ] keep values dup finish-live-intervals ; : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 2976680857..6fd97c64da 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -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 ; \ No newline at end of file + check-numbering? get + [ linearization-order [ check-block-numbering ] each ] [ drop ] if ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index ee3595dd06..47c1f0ae76 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -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 1 int-regs add-mapping + 0 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 \ No newline at end of file +] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index b1fe1572cd..b45e2c9597 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -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 - insert-basic-block + mapping-instructions 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 ; diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor deleted file mode 100644 index fe8b4fd0c0..0000000000 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: compiler.cfg.linearization.tests -USING: compiler.cfg.linearization tools.test ; - - diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index cbeb301901..32df6233bd 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -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 +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 ; diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor index c09c2969ba..703db8e516 100644 --- a/basis/compiler/cfg/linearization/order/order.factor +++ b/basis/compiler/cfg/linearization/order/order.factor @@ -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 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>> [ loop-nesting-at ] sort-with ; : process-block ( bb -- ) - { - [ , ] - [ assign-number ] - [ visited get conjoin ] - [ successors>> [ 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. - 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index 0bb5f85fa5..e4f5144e1f 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -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 \ No newline at end of file +[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 6c67769a45..a10b48cc0c 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -28,4 +28,4 @@ M: live-analysis transfer-set drop instructions>> transfer-liveness ; M: live-analysis join-sets - drop assoc-combine ; \ No newline at end of file + 2drop assoc-combine ; diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor new file mode 100644 index 0000000000..81263c8e9a --- /dev/null +++ b/basis/compiler/cfg/liveness/ssa/ssa.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces deques accessors sets sequences assocs fry +hashtables dlists compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities +compiler.cfg.predecessors ; +IN: compiler.cfg.liveness.ssa + +! TODO: merge with compiler.cfg.liveness + +! Assoc mapping basic blocks to sequences of sets of vregs; each sequence +! is in correspondence with a predecessor +SYMBOL: phi-live-ins + +: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +: compute-live-in ( basic-block -- live-in ) + [ live-out ] keep instructions>> transfer-liveness ; + +: compute-phi-live-in ( basic-block -- phi-live-in ) + H{ } clone [ + '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi + ] keep ; + +: update-live-in ( basic-block -- changed? ) + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] + bi or ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ phi-live-in ] with map ] bi + append assoc-combine ; + +: update-live-out ( basic-block -- changed? ) + [ compute-live-out ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-ssa-live-sets ( cfg -- cfg' ) + needs-predecessors + + work-list set + H{ } clone live-ins set + H{ } clone phi-live-ins set + H{ } clone live-outs set + dup post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; + +: live-in? ( vreg bb -- ? ) live-in key? ; + +: live-out? ( vreg bb -- ? ) live-out key? ; \ No newline at end of file diff --git a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor new file mode 100644 index 0000000000..80203c65e4 --- /dev/null +++ b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor @@ -0,0 +1,20 @@ +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 +V{ } 2 test-bb + +0 { 1 2 } edges +2 0 edge + +: test-loop-detection ( -- ) cfg new 0 get >>entry needs-loops drop ; + +[ ] [ test-loop-detection ] unit-test + +[ 1 ] [ 0 get loop-nesting-at ] unit-test +[ 0 ] [ 1 get loop-nesting-at ] unit-test +[ 1 ] [ 2 get loop-nesting-at ] unit-test diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor new file mode 100644 index 0000000000..dc70656c08 --- /dev/null +++ b/basis/compiler/cfg/loop-detection/loop-detection.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators deques dlists fry kernel +namespaces sequences sets compiler.cfg compiler.cfg.predecessors ; +IN: compiler.cfg.loop-detection + +TUPLE: natural-loop header index ends blocks ; + + ( header index -- loop ) + H{ } clone H{ } clone natural-loop boa ; + +: lookup-header ( header -- loop ) + loops get [ + loops get assoc-size + ] cache ; + +SYMBOLS: visited active ; + +: record-back-edge ( from to -- ) + lookup-header ends>> conjoin ; + +DEFER: find-loop-headers + +: visit-edge ( from to -- ) + dup active get key? + [ record-back-edge ] + [ nip find-loop-headers ] + if ; + +: find-loop-headers ( bb -- ) + dup visited get key? [ drop ] [ + { + [ visited get conjoin ] + [ active get conjoin ] + [ dup successors>> [ visit-edge ] with each ] + [ active get delete-at ] + } cleave + ] if ; + +SYMBOL: work-list + +: process-loop-block ( bb loop -- ) + 2dup blocks>> key? [ 2drop ] [ + [ blocks>> conjoin ] [ + 2dup header>> eq? [ 2drop ] [ + drop predecessors>> work-list get push-all-front + ] if + ] 2bi + ] if ; + +: process-loop-ends ( loop -- ) + [ ends>> keys [ push-all-front ] [ work-list set ] [ ] tri ] keep + '[ _ process-loop-block ] slurp-deque ; + +: process-loop-headers ( -- ) + loops get values [ process-loop-ends ] each ; + +SYMBOL: loop-nesting + +: compute-loop-nesting ( -- ) + loops get H{ } clone [ + [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each + ] keep loop-nesting set ; + +: detect-loops ( cfg -- cfg' ) + needs-predecessors + H{ } clone loops set + H{ } clone visited set + H{ } clone active set + H{ } clone loop-nesting set + dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ; + +PRIVATE> + +: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ; + +: needs-loops ( cfg -- cfg' ) + needs-predecessors + dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ; \ No newline at end of file diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor index cb198d5149..de679cbcc2 100644 --- a/basis/compiler/cfg/mr/mr.factor +++ b/basis/compiler/cfg/mr/mr.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.gc-checks compiler.cfg.linear-scan -compiler.cfg.build-stack-frame compiler.cfg.rpo ; +USING: kernel namespaces accessors compiler.cfg +compiler.cfg.linearization compiler.cfg.gc-checks +compiler.cfg.linear-scan compiler.cfg.build-stack-frame ; IN: compiler.cfg.mr : build-mr ( cfg -- mr ) - convert-two-operand insert-gc-checks linear-scan flatten-cfg diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor deleted file mode 100755 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 8e2df04cca..649032b469 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -11,10 +11,10 @@ compiler.cfg.value-numbering compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier +compiler.cfg.representations +compiler.cfg.two-operand compiler.cfg.ssa.destruction compiler.cfg.empty-blocks -compiler.cfg.predecessors -compiler.cfg.rpo compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -26,23 +26,18 @@ SYMBOL: check-optimizer? ] when ; : optimize-cfg ( cfg -- cfg' ) - ! Note that compute-predecessors has to be called several times. - ! The passes that need this document it. - [ - optimize-tail-calls - delete-useless-conditionals - compute-predecessors - split-branches - join-blocks - compute-predecessors - construct-ssa - alias-analysis - value-numbering - compute-predecessors - copy-propagation - eliminate-dead-code - eliminate-write-barriers - destruct-ssa - delete-empty-blocks - ?check - ] with-scope ; + optimize-tail-calls + delete-useless-conditionals + split-branches + join-blocks + construct-ssa + alias-analysis + value-numbering + copy-propagation + eliminate-dead-code + eliminate-write-barriers + select-representations + convert-two-operand + destruct-ssa + delete-empty-blocks + ?check ; diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor index 17b043c1b7..66cc87beff 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor @@ -11,53 +11,53 @@ SYMBOL: temp [ { - T{ ##copy f V int-regs 4 V int-regs 2 } - T{ ##copy f V int-regs 2 V int-regs 1 } - T{ ##copy f V int-regs 1 V int-regs 4 } + T{ ##copy f 4 2 any-rep } + T{ ##copy f 2 1 any-rep } + T{ ##copy f 1 4 any-rep } } ] [ H{ - { V int-regs 1 V int-regs 2 } - { V int-regs 2 V int-regs 1 } + { 1 2 } + { 2 1 } } test-parallel-copy ] unit-test [ { - T{ ##copy f V int-regs 1 V int-regs 2 } - T{ ##copy f V int-regs 3 V int-regs 4 } + T{ ##copy f 1 2 any-rep } + T{ ##copy f 3 4 any-rep } } ] [ H{ - { V int-regs 1 V int-regs 2 } - { V int-regs 3 V int-regs 4 } + { 1 2 } + { 3 4 } } test-parallel-copy ] unit-test [ { - T{ ##copy f V int-regs 1 V int-regs 3 } - T{ ##copy f V int-regs 2 V int-regs 1 } + T{ ##copy f 1 3 any-rep } + T{ ##copy f 2 1 any-rep } } ] [ H{ - { V int-regs 1 V int-regs 3 } - { V int-regs 2 V int-regs 3 } + { 1 3 } + { 2 3 } } test-parallel-copy ] unit-test [ { - T{ ##copy f V int-regs 4 V int-regs 3 } - T{ ##copy f V int-regs 3 V int-regs 2 } - T{ ##copy f V int-regs 2 V int-regs 1 } - T{ ##copy f V int-regs 1 V int-regs 4 } + T{ ##copy f 4 3 any-rep } + T{ ##copy f 3 2 any-rep } + T{ ##copy f 2 1 any-rep } + T{ ##copy f 1 4 any-rep } } ] [ { - { V int-regs 2 V int-regs 1 } - { V int-regs 3 V int-regs 2 } - { V int-regs 1 V int-regs 3 } - { V int-regs 4 V int-regs 3 } + { 2 1 } + { 3 2 } + { 1 3 } + { 4 3 } } test-parallel-copy ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor index 5a1bfcd111..ef4bada633 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs compiler.cfg.hats compiler.cfg.instructions -deques dlists fry kernel locals namespaces sequences -hashtables ; +USING: assocs cpu.architecture compiler.cfg.registers +compiler.cfg.instructions deques dlists fry kernel locals namespaces +sequences hashtables ; IN: compiler.cfg.parallel-copy ! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency @@ -57,4 +57,5 @@ PRIVATE> ] slurp-deque ] with-scope ; inline -: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ; \ No newline at end of file +: parallel-copy ( mapping -- ) + next-vreg [ any-rep ##copy ] parallel-mapping ; \ No newline at end of file diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index c972197dd8..8ab9f316a7 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -4,6 +4,8 @@ USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.predecessors +> [ predecessors>> push ] with each ; @@ -23,3 +25,9 @@ IN: compiler.cfg.predecessors [ [ update-phis ] each-basic-block ] [ ] } cleave ; + +PRIVATE> + +: needs-predecessors ( cfg -- cfg' ) + dup predecessors-valid?>> + [ compute-predecessors t >>predecessors-valid? ] unless ; \ No newline at end of file diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index c5b3907153..0d518735af 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,18 +1,32 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel arrays parser math math.order ; +USING: accessors namespaces kernel parser assocs ; IN: compiler.cfg.registers -! Virtual registers, used by CFG and machine IRs -TUPLE: vreg { reg-class read-only } { n fixnum read-only } ; - -M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ; - -M: vreg hashcode* nip n>> ; - +! Virtual registers, used by CFG and machine IRs, are just integers SYMBOL: vreg-counter -: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; +: next-vreg ( -- vreg ) + ! This word cannot be called AFTER representation selection has run; + ! use next-vreg-rep in that case + \ vreg-counter counter ; + +SYMBOL: representations + +ERROR: bad-vreg vreg ; + +: rep-of ( vreg -- rep ) + ! This word cannot be called BEFORE representation selection has run; + ! use any-rep for ##copy instructions and so on + representations get ?at [ bad-vreg ] unless ; + +: set-rep-of ( rep vreg -- ) + representations get set-at ; + +: next-vreg-rep ( rep -- vreg ) + ! This word cannot be called BEFORE representation selection has run; + ! use next-vreg in that case + next-vreg [ set-rep-of ] keep ; ! Stack locations -- 'n' is an index starting from the top of the stack ! going down. So 0 is the top of the stack, 1 is what would be the top @@ -28,6 +42,5 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -SYNTAX: V scan-word scan-word vreg boa parsed ; SYNTAX: D scan-word parsed ; SYNTAX: R scan-word parsed ; diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index 3d032f7510..92a6954786 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -10,7 +10,4 @@ SYMBOL: renamings : rename-value ( vreg -- vreg' ) renamings get ?at drop ; -: fresh-value ( vreg -- vreg' ) - reg-class>> next-vreg ; - -RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ] +RENAMING: rename [ rename-value ] [ rename-value ] [ drop next-vreg ] diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor new file mode 100644 index 0000000000..e9ec7e8835 --- /dev/null +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences arrays fry namespaces +cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo +compiler.cfg.instructions compiler.cfg.def-use ; +IN: compiler.cfg.representations.preferred + +GENERIC: defs-vreg-rep ( insn -- rep/f ) +GENERIC: temp-vreg-reps ( insn -- reps ) +GENERIC: uses-vreg-reps ( insn -- reps ) + +M: ##flushable defs-vreg-rep drop int-rep ; +M: ##copy defs-vreg-rep rep>> ; +M: output-float-insn defs-vreg-rep drop double-float-rep ; +M: ##fixnum-overflow defs-vreg-rep drop int-rep ; +M: _fixnum-overflow defs-vreg-rep drop int-rep ; +M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ; +M: insn defs-vreg-rep drop f ; + +M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ; +M: ##unary/temp temp-vreg-reps drop { int-rep } ; +M: ##allot temp-vreg-reps drop { int-rep } ; +M: ##dispatch temp-vreg-reps drop { int-rep } ; +M: ##slot temp-vreg-reps drop { int-rep } ; +M: ##set-slot temp-vreg-reps drop { int-rep } ; +M: ##string-nth temp-vreg-reps drop { int-rep } ; +M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ; +M: ##compare temp-vreg-reps drop { int-rep } ; +M: ##compare-imm temp-vreg-reps drop { int-rep } ; +M: ##compare-float temp-vreg-reps drop { int-rep } ; +M: ##gc temp-vreg-reps drop { int-rep int-rep } ; +M: _dispatch temp-vreg-reps drop { int-rep } ; +M: insn temp-vreg-reps drop f ; + +M: ##copy uses-vreg-reps rep>> 1array ; +M: ##unary uses-vreg-reps drop { int-rep } ; +M: ##unary-float uses-vreg-reps drop { double-float-rep } ; +M: ##binary uses-vreg-reps drop { int-rep int-rep } ; +M: ##binary-imm uses-vreg-reps drop { int-rep } ; +M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: ##effect uses-vreg-reps drop { int-rep } ; +M: ##slot uses-vreg-reps drop { int-rep int-rep } ; +M: ##slot-imm uses-vreg-reps drop { int-rep } ; +M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ; +M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ; +M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ; +M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ; +M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ; +M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ; +M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: ##dispatch uses-vreg-reps drop { int-rep } ; +M: ##alien-getter uses-vreg-reps drop { int-rep } ; +M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ; +M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ; +M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ; +M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ; +M: _compare-imm-branch uses-vreg-reps drop { int-rep } ; +M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ; +M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: _dispatch uses-vreg-reps drop { int-rep } ; +M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ; +M: insn uses-vreg-reps drop f ; + +: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline + +: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline + +: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline + +: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- ) + '[ + [ basic-block set ] [ + [ + _ + [ each-def-rep ] + [ each-use-rep ] + [ each-temp-rep ] 2tri + ] each-non-phi + ] bi + ] each-basic-block ; inline diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor new file mode 100644 index 0000000000..29f0fa064f --- /dev/null +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -0,0 +1,19 @@ +USING: tools.test cpu.architecture +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.representations.preferred ; +IN: compiler.cfg.representations + +[ { double-float-rep double-float-rep } ] [ + T{ ##add-float + { dst 5 } + { src1 3 } + { src2 4 } + } uses-vreg-reps +] unit-test + +[ double-float-rep ] [ + T{ ##alien-double + { dst 5 } + { src 3 } + } defs-vreg-rep +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor new file mode 100644 index 0000000000..cb98eb0ae5 --- /dev/null +++ b/basis/compiler/cfg/representations/representations.factor @@ -0,0 +1,229 @@ +! Copyright (C) 2009 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel fry accessors sequences assocs sets namespaces +arrays combinators make locals deques dlists +cpu.architecture compiler.utilities +compiler.cfg +compiler.cfg.rpo +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.def-use +compiler.cfg.utilities +compiler.cfg.loop-detection +compiler.cfg.renaming.functor +compiler.cfg.representations.preferred ; +IN: compiler.cfg.representations + +! Virtual register representation selection. + +: emit-conversion ( dst src dst-rep src-rep -- ) + 2array { + { { int-rep int-rep } [ int-rep ##copy ] } + { { double-float-rep double-float-rep } [ double-float-rep ##copy ] } + { { double-float-rep int-rep } [ ##unbox-float ] } + { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] } + } case ; + +assoc ] assoc-map costs set ; + +: increase-cost ( rep vreg -- ) + ! Increase cost of keeping vreg in rep, making a choice of rep less + ! likely. + [ basic-block get loop-nesting-at ] 2dip costs get at at+ ; + +: maybe-increase-cost ( possible vreg preferred -- ) + pick eq? [ 2drop ] [ increase-cost ] if ; + +: representation-cost ( vreg preferred -- ) + ! 'preferred' is a representation that the instruction can accept with no cost. + ! So, for each representation that's not preferred, increase the cost of keeping + ! the vreg in that representation. + [ drop possible ] + [ '[ _ _ maybe-increase-cost ] ] + 2bi each ; + +: compute-costs ( cfg -- costs ) + init-costs [ representation-cost ] with-vreg-reps costs get ; + +! For every vreg, compute preferred representation, that minimizes costs. +: minimize-costs ( costs -- representations ) + [ >alist alist-min first ] assoc-map ; + +: compute-representations ( cfg -- ) + [ compute-costs minimize-costs ] + [ compute-always-boxed ] + bi assoc-union + representations set ; + +! Insert conversions. This introduces new temporaries, so we need +! to rename opearands too. + +:: emit-def-conversion ( dst preferred required -- new-dst' ) + ! If an instruction defines a register with representation 'required', + ! but the register has preferred representation 'preferred', then + ! we rename the instruction's definition to a new register, which + ! becomes the input of a conversion instruction. + dst required next-vreg-rep [ preferred required emit-conversion ] keep ; + +:: emit-use-conversion ( src preferred required -- new-src' ) + ! If an instruction uses a register with representation 'required', + ! but the register has preferred representation 'preferred', then + ! we rename the instruction's input to a new register, which + ! becomes the output of a conversion instruction. + required next-vreg-rep [ src required preferred emit-conversion ] keep ; + +SYMBOLS: renaming-set needs-renaming? ; + +: init-renaming-set ( -- ) + needs-renaming? off + V{ } clone renaming-set set ; + +: no-renaming ( vreg -- ) + dup 2array renaming-set get push ; + +: record-renaming ( from to -- ) + 2array renaming-set get push needs-renaming? on ; + +:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- ) + vreg rep-of :> preferred + preferred required eq? + [ vreg no-renaming ] + [ vreg vreg preferred required quot call record-renaming ] if ; inline + +: compute-renaming-set ( insn -- ) + ! temp vregs don't need conversions since they're always in their + ! preferred representation + init-renaming-set + [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ] + [ , ] + [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ] + tri ; + +: converted-value ( vreg -- vreg' ) + renaming-set get pop first2 [ assert= ] dip ; + +RENAMING: convert [ converted-value ] [ converted-value ] [ ] + +: perform-renaming ( insn -- ) + needs-renaming? get [ + renaming-set get reverse-here + [ convert-insn-uses ] [ convert-insn-defs ] bi + renaming-set get length 0 assert= + ] [ drop ] if ; + +GENERIC: conversions-for-insn ( insn -- ) + +SYMBOL: phi-mappings + +! compiler.cfg.cssa inserts conversions which convert phi inputs into +! the representation of the output. However, we still have to do some +! processing here, because if the only node that uses the output of +! the phi instruction is another phi instruction then this phi node's +! output won't have a representation assigned. +M: ##phi conversions-for-insn + [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ; + +M: vreg-insn conversions-for-insn + [ compute-renaming-set ] [ perform-renaming ] bi ; + +M: insn conversions-for-insn , ; + +: conversions-for-block ( bb -- ) + dup kill-block? [ drop ] [ + [ + [ + [ conversions-for-insn ] each + ] V{ } make + ] change-instructions drop + ] if ; + +! If the output of a phi instruction is only used as the input to another +! phi instruction, then we want to use the same representation for both +! if possible. +SYMBOL: work-list + +: add-to-work-list ( vregs -- ) + work-list get push-all-front ; + +: rep-assigned ( vregs -- vregs' ) + representations get '[ _ key? ] filter ; + +: rep-not-assigned ( vregs -- vregs' ) + representations get '[ _ key? not ] filter ; + +: add-ready-phis ( -- ) + phi-mappings get keys rep-assigned add-to-work-list ; + +: process-phi-mapping ( dst -- ) + ! If dst = phi(src1,src2,...) and dst's representation has been + ! determined, assign that representation to each one of src1,... + ! that does not have a representation yet, and process those, too. + dup phi-mappings get at* [ + [ rep-of ] [ rep-not-assigned ] bi* + [ [ set-rep-of ] with each ] [ add-to-work-list ] bi + ] [ 2drop ] if ; + +: remaining-phi-mappings ( -- ) + phi-mappings get keys rep-not-assigned + [ [ int-rep ] dip set-rep-of ] each ; + +: process-phi-mappings ( -- ) + work-list set + add-ready-phis + work-list get [ process-phi-mapping ] slurp-deque + remaining-phi-mappings ; + +: insert-conversions ( cfg -- ) + H{ } clone phi-mappings set + [ conversions-for-block ] each-basic-block + process-phi-mappings ; + +PRIVATE> + +: select-representations ( cfg -- cfg' ) + needs-loops + + { + [ compute-possibilities ] + [ compute-representations ] + [ insert-conversions ] + [ ] + } cleave + representations get cfg get (>>reps) ; \ No newline at end of file diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 1ddacdf8ab..b6322730ee 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -39,4 +39,7 @@ SYMBOL: visited [ change-instructions drop ] 2bi ; inline : local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' ) - dupd '[ _ optimize-basic-block ] each-basic-block ; inline \ No newline at end of file + dupd '[ _ optimize-basic-block ] each-basic-block ; inline + +: needs-post-order ( cfg -- cfg' ) + dup post-order drop ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor index e7ba5bbaba..3d743176b1 100644 --- a/basis/compiler/cfg/ssa/construction/construction-tests.factor +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -13,24 +13,24 @@ IN: compiler.cfg.ssa.construction.tests reset-counters V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 1 50 } - T{ ##add-imm f V int-regs 2 V int-regs 2 10 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 1 50 } + T{ ##add-imm f 2 2 10 } T{ ##branch } } 0 test-bb V{ - T{ ##load-immediate f V int-regs 3 3 } + T{ ##load-immediate f 3 3 } T{ ##branch } } 1 test-bb V{ - T{ ##load-immediate f V int-regs 3 4 } + T{ ##load-immediate f 3 4 } 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 @@ -40,7 +40,7 @@ V{ : test-ssa ( -- ) cfg new 0 get >>entry - compute-predecessors + dup cfg set construct-ssa drop ; @@ -48,23 +48,23 @@ V{ [ V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 1 50 } - T{ ##add-imm f V int-regs 3 V int-regs 2 10 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 1 50 } + T{ ##add-imm f 3 2 10 } T{ ##branch } } ] [ 0 get instructions>> ] unit-test [ V{ - T{ ##load-immediate f V int-regs 4 3 } + T{ ##load-immediate f 4 3 } T{ ##branch } } ] [ 1 get instructions>> ] unit-test [ V{ - T{ ##load-immediate f V int-regs 5 4 } + T{ ##load-immediate f 5 4 } T{ ##branch } } ] [ 2 get instructions>> ] unit-test @@ -74,8 +74,8 @@ V{ [ V{ - T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } } - T{ ##replace f V int-regs 6 D 0 } + T{ ##phi f 6 H{ { 1 4 } { 2 5 } } } + T{ ##replace f 6 D 0 } T{ ##return } } ] [ @@ -87,9 +87,9 @@ reset-counters V{ } 0 test-bb V{ } 1 test-bb -V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb -V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb -V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb +V{ T{ ##peek f 0 D 0 } } 2 test-bb +V{ T{ ##peek f 0 D 0 } } 3 test-bb +V{ T{ ##replace f 0 D 0 } } 4 test-bb V{ } 5 test-bb V{ } 6 test-bb @@ -104,8 +104,8 @@ V{ } 6 test-bb [ V{ - T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } } - T{ ##replace f V int-regs 3 D 0 } + T{ ##phi f 3 H{ { 2 1 } { 3 2 } } } + T{ ##replace f 3 D 0 } } ] [ 4 get instructions>> diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index d2c7698999..7662b8ab01 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -9,12 +9,11 @@ compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.renaming compiler.cfg.renaming.functor compiler.cfg.ssa.construction.tdmsc ; IN: compiler.cfg.ssa.construction -! SSA construction. Predecessors must be computed first. - ! The phi placement algorithm is implemented in ! compiler.cfg.ssa.construction.tdmsc. @@ -75,7 +74,7 @@ SYMBOLS: stacks pushed ; H{ } clone stacks set ; : gen-name ( vreg -- vreg' ) - [ reg-class>> next-vreg dup ] keep + [ next-vreg dup ] dip dup pushed get 2dup key? [ 2drop stacks get at set-last ] [ conjoin stacks get push-at ] @@ -131,10 +130,9 @@ PRIVATE> : construct-ssa ( cfg -- cfg' ) { - [ ] [ compute-live-sets ] - [ compute-dominance ] [ compute-merge-sets ] [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] + [ ] } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor index 433dcfee64..955d41814f 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor @@ -5,9 +5,7 @@ tools.test vectors sets ; IN: compiler.cfg.ssa.construction.tdmsc.tests : test-tdmsc ( -- ) - cfg new 0 get >>entry - compute-predecessors - dup compute-dominance + cfg new 0 get >>entry dup cfg set compute-merge-sets ; V{ } 0 test-bb diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 1c1abefe1b..647c97d6c3 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -93,7 +93,8 @@ HINTS: filter-by { bit-array object } ; PRIVATE> : compute-merge-sets ( cfg -- ) - dup cfg set + needs-dominance + H{ } clone visited set [ compute-levels ] [ init-merge-sets ] diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index 37fa790453..14287e900f 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -1,21 +1,25 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel locals +USING: accessors assocs kernel locals fry +cpu.architecture compiler.cfg.rpo -compiler.cfg.hats compiler.cfg.utilities -compiler.cfg.instructions ; +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.representations ; IN: compiler.cfg.ssa.cssa -! Convert SSA to conventional SSA. +! Convert SSA to conventional SSA. This pass runs after representation +! selection, so it must keep track of representations when introducing +! new values. -:: insert-copy ( bb src -- bb dst ) - i :> dst - bb [ dst src ##copy ] add-instructions +:: insert-copy ( bb src rep -- bb dst ) + rep next-vreg-rep :> dst + bb [ dst src rep src rep-of emit-conversion ] add-instructions bb dst ; : convert-phi ( ##phi -- ) - [ [ insert-copy ] assoc-map ] change-inputs drop ; + dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ; : construct-cssa ( cfg -- ) [ [ convert-phi ] each-phi ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 535dc6db86..424be91e2b 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -8,7 +8,7 @@ compiler.cfg.def-use compiler.cfg.renaming compiler.cfg.dominance compiler.cfg.instructions -compiler.cfg.ssa.liveness +compiler.cfg.liveness.ssa compiler.cfg.ssa.cssa compiler.cfg.ssa.interference compiler.cfg.ssa.interference.live-ranges @@ -49,7 +49,9 @@ SYMBOL: copies : eliminate-copy ( vreg1 vreg2 -- ) [ leader ] bi@ 2dup eq? [ 2drop ] [ - [ update-leaders ] [ merge-classes ] 2bi + [ update-leaders ] + [ merge-classes ] + 2bi ] if ; : introduce-vreg ( vreg -- ) @@ -95,13 +97,12 @@ M: insn prepare-insn drop ; ] each-basic-block ; : destruct-ssa ( cfg -- cfg' ) - dup cfg-has-phis? [ - dup construct-cssa - dup precompute-liveness - dup compute-defs - dup compute-dominance - dup compute-live-ranges - dup prepare-coalescing - process-copies - dup perform-renaming - ] when ; + needs-dominance + + dup construct-cssa + dup compute-defs + compute-ssa-live-sets + dup compute-live-ranges + dup prepare-coalescing + process-copies + dup perform-renaming ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor index 9075d3b010..2f13331024 100644 --- a/basis/compiler/cfg/ssa/interference/interference-tests.factor +++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor @@ -1,6 +1,6 @@ USING: accessors compiler.cfg compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.dominance -compiler.cfg.instructions compiler.cfg.ssa.liveness +compiler.cfg.instructions compiler.cfg.liveness.ssa compiler.cfg.registers compiler.cfg.predecessors compiler.cfg.ssa.interference compiler.cfg.ssa.interference.live-ranges cpu.architecture @@ -9,26 +9,24 @@ IN: compiler.cfg.ssa.interference.tests : test-interference ( -- ) cfg new 0 get >>entry - compute-predecessors - dup precompute-liveness + compute-ssa-live-sets dup compute-defs - dup compute-dominance compute-live-ranges ; V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 2 D 0 } - T{ ##copy f V int-regs 1 V int-regs 0 } - T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##peek f 2 D 0 } + T{ ##copy f 1 0 } + T{ ##copy f 3 2 } T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 4 D 0 } - T{ ##peek f V int-regs 5 D 0 } - T{ ##replace f V int-regs 3 D 0 } - T{ ##peek f V int-regs 6 D 0 } - T{ ##replace f V int-regs 5 D 0 } + T{ ##peek f 4 D 0 } + T{ ##peek f 5 D 0 } + T{ ##replace f 3 D 0 } + T{ ##peek f 6 D 0 } + T{ ##replace f 5 D 0 } T{ ##return } } 1 test-bb @@ -36,17 +34,17 @@ V{ [ ] [ test-interference ] unit-test -[ f ] [ V int-regs 0 V int-regs 1 vregs-interfere? ] unit-test -[ f ] [ V int-regs 1 V int-regs 0 vregs-interfere? ] unit-test -[ f ] [ V int-regs 2 V int-regs 3 vregs-interfere? ] unit-test -[ f ] [ V int-regs 3 V int-regs 2 vregs-interfere? ] unit-test -[ t ] [ V int-regs 0 V int-regs 2 vregs-interfere? ] unit-test -[ t ] [ V int-regs 2 V int-regs 0 vregs-interfere? ] unit-test -[ f ] [ V int-regs 1 V int-regs 3 vregs-interfere? ] unit-test -[ f ] [ V int-regs 3 V int-regs 1 vregs-interfere? ] unit-test -[ t ] [ V int-regs 3 V int-regs 4 vregs-interfere? ] unit-test -[ t ] [ V int-regs 4 V int-regs 3 vregs-interfere? ] unit-test -[ t ] [ V int-regs 3 V int-regs 5 vregs-interfere? ] unit-test -[ t ] [ V int-regs 5 V int-regs 3 vregs-interfere? ] unit-test -[ f ] [ V int-regs 3 V int-regs 6 vregs-interfere? ] unit-test -[ f ] [ V int-regs 6 V int-regs 3 vregs-interfere? ] unit-test +[ f ] [ 0 1 vregs-interfere? ] unit-test +[ f ] [ 1 0 vregs-interfere? ] unit-test +[ f ] [ 2 3 vregs-interfere? ] unit-test +[ f ] [ 3 2 vregs-interfere? ] unit-test +[ t ] [ 0 2 vregs-interfere? ] unit-test +[ t ] [ 2 0 vregs-interfere? ] unit-test +[ f ] [ 1 3 vregs-interfere? ] unit-test +[ f ] [ 3 1 vregs-interfere? ] unit-test +[ t ] [ 3 4 vregs-interfere? ] unit-test +[ t ] [ 4 3 vregs-interfere? ] unit-test +[ t ] [ 3 5 vregs-interfere? ] unit-test +[ t ] [ 5 3 vregs-interfere? ] unit-test +[ f ] [ 3 6 vregs-interfere? ] unit-test +[ f ] [ 6 3 vregs-interfere? ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor index f8553ec9de..a76b55cd83 100644 --- a/basis/compiler/cfg/ssa/interference/interference.factor +++ b/basis/compiler/cfg/ssa/interference/interference.factor @@ -6,6 +6,11 @@ compiler.cfg.def-use compiler.cfg.dominance compiler.cfg.ssa.interference.live-ranges ; IN: compiler.cfg.ssa.interference +! Interference testing using SSA properties. Actually the only SSA property +! used here is that definitions dominate uses; because of this, the input +! is allowed to have multiple definitions of each vreg as long as they're +! all in the same basic block. This is needed because two-operand conversion +! runs before coalescing, which uses SSA interference testing. [ 2drop 2drop f ] } cond ; -! Debug this stuff later : sort-vregs-by-bb ( vregs -- alist ) defs get '[ dup _ at ] { } map>assoc - [ [ second pre-of ] compare ] sort ; + [ second pre-of ] sort-with ; : ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index c29b69cf36..fd1f09a900 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel namespaces sequences math arrays compiler.cfg.def-use compiler.cfg.instructions -compiler.cfg.ssa.liveness compiler.cfg.rpo ; +compiler.cfg.liveness.ssa compiler.cfg.rpo compiler.cfg.dominance ; IN: compiler.cfg.ssa.interference.live-ranges ! Live ranges for interference testing @@ -11,8 +11,13 @@ IN: compiler.cfg.ssa.interference.live-ranges SYMBOLS: local-def-indices local-kill-indices ; -: record-def ( n vregs -- ) - dup [ local-def-indices get set-at ] [ 2drop ] if ; +: record-def ( n vreg -- ) + ! We allow multiple defs of a vreg as long as they're + ! all in the same basic block + dup [ + local-def-indices get 2dup key? + [ 3drop ] [ set-at ] if + ] [ 2drop ] if ; : record-uses ( n vregs -- ) local-kill-indices get '[ _ set-at ] with each ; @@ -42,6 +47,8 @@ SYMBOLS: def-indices kill-indices ; PRIVATE> : compute-live-ranges ( cfg -- ) + needs-dominance + H{ } clone def-indices set H{ } clone kill-indices set [ compute-local-live-ranges ] each-basic-block ; diff --git a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor index 137fa0371f..bc5807087d 100644 --- a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor @@ -9,7 +9,9 @@ compiler.cfg.ssa.liveness compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.predecessors -compiler.cfg.registers ; +compiler.cfg.registers +compiler.cfg.dominance +compiler.cfg.def-use ; IN: compiler.cfg.ssa.liveness [ t ] [ { 1 } 1 only? ] unit-test @@ -17,138 +19,140 @@ IN: compiler.cfg.ssa.liveness [ f ] [ { 2 1 } 1 only? ] unit-test [ f ] [ { 2 } 1 only? ] unit-test +: test-liveness ( -- ) + cfg new 0 get >>entry + dup compute-defs + dup compute-uses + needs-dominance + precompute-liveness ; + 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 0 D 0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } +} 0 test-bb + +V{ + T{ ##replace f 2 D 0 } } 1 test-bb V{ - T{ ##replace f V int-regs 2 D 0 } + T{ ##replace f 3 D 0 } } 2 test-bb -V{ - T{ ##replace f V int-regs 3 D 0 } -} 3 test-bb +0 { 1 2 } edges -1 { 2 3 } edges - -cfg new 1 get >>entry 4 set - -[ ] [ 4 get compute-predecessors drop ] unit-test -[ ] [ 4 get precompute-liveness ] unit-test +[ ] [ test-liveness ] unit-test [ H{ } ] [ back-edge-targets get ] unit-test -[ H{ } ] [ phi-outs get ] unit-test -[ t ] [ 1 get R_q { 1 2 3 } [ get ] map unique = ] unit-test +[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test +[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test [ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test -[ t ] [ 3 get R_q { 3 } [ get ] map unique = ] unit-test : self-T_q ( n -- ? ) get [ T_q ] [ 1array unique ] bi = ; +[ t ] [ 0 self-T_q ] unit-test [ t ] [ 1 self-T_q ] unit-test [ t ] [ 2 self-T_q ] unit-test -[ t ] [ 3 self-T_q ] unit-test -[ f ] [ V int-regs 0 1 get live-in? ] unit-test -[ t ] [ V int-regs 1 1 get live-in? ] unit-test -[ t ] [ V int-regs 2 1 get live-in? ] unit-test -[ t ] [ V int-regs 3 1 get live-in? ] unit-test +[ f ] [ 0 0 get live-in? ] unit-test +[ t ] [ 1 0 get live-in? ] unit-test +[ t ] [ 2 0 get live-in? ] unit-test +[ t ] [ 3 0 get live-in? ] unit-test -[ f ] [ V int-regs 0 1 get live-out? ] unit-test -[ f ] [ V int-regs 1 1 get live-out? ] unit-test -[ t ] [ V int-regs 2 1 get live-out? ] unit-test -[ t ] [ V int-regs 3 1 get live-out? ] unit-test +[ f ] [ 0 0 get live-out? ] unit-test +[ f ] [ 1 0 get live-out? ] unit-test +[ t ] [ 2 0 get live-out? ] unit-test +[ t ] [ 3 0 get live-out? ] unit-test -[ f ] [ V int-regs 0 2 get live-in? ] unit-test -[ f ] [ V int-regs 1 2 get live-in? ] unit-test -[ t ] [ V int-regs 2 2 get live-in? ] unit-test -[ f ] [ V int-regs 3 2 get live-in? ] unit-test +[ f ] [ 0 1 get live-in? ] unit-test +[ f ] [ 1 1 get live-in? ] unit-test +[ t ] [ 2 1 get live-in? ] unit-test +[ f ] [ 3 1 get live-in? ] unit-test -[ f ] [ V int-regs 0 2 get live-out? ] unit-test -[ f ] [ V int-regs 1 2 get live-out? ] unit-test -[ f ] [ V int-regs 2 2 get live-out? ] unit-test -[ f ] [ V int-regs 3 2 get live-out? ] unit-test +[ f ] [ 0 1 get live-out? ] unit-test +[ f ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test +[ f ] [ 3 1 get live-out? ] unit-test -[ f ] [ V int-regs 0 3 get live-in? ] unit-test -[ f ] [ V int-regs 1 3 get live-in? ] unit-test -[ f ] [ V int-regs 2 3 get live-in? ] unit-test -[ t ] [ V int-regs 3 3 get live-in? ] unit-test +[ f ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test +[ t ] [ 3 2 get live-in? ] unit-test -[ f ] [ V int-regs 0 3 get live-out? ] unit-test -[ f ] [ V int-regs 1 3 get live-out? ] unit-test -[ f ] [ V int-regs 2 3 get live-out? ] unit-test -[ f ] [ V int-regs 3 3 get live-out? ] unit-test +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test +[ f ] [ 3 2 get live-out? ] unit-test V{ } 0 test-bb V{ } 1 test-bb V{ } 2 test-bb V{ } 3 test-bb V{ - T{ ##phi f V int-regs 2 H{ { 2 V int-regs 0 } { 3 V int-regs 1 } } } + T{ ##phi f 2 H{ { 2 0 } { 3 1 } } } } 4 test-bb test-diamond -cfg new 1 get >>entry 5 set +[ ] [ test-liveness ] unit-test -[ ] [ 5 get compute-predecessors drop ] unit-test -[ ] [ 5 get precompute-liveness ] unit-test +[ t ] [ 0 1 get live-in? ] unit-test +[ t ] [ 1 1 get live-in? ] unit-test +[ f ] [ 2 1 get live-in? ] unit-test -[ t ] [ V int-regs 0 1 get live-in? ] unit-test -[ t ] [ V int-regs 1 1 get live-in? ] unit-test -[ f ] [ V int-regs 2 1 get live-in? ] unit-test +[ t ] [ 0 1 get live-out? ] unit-test +[ t ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test -[ t ] [ V int-regs 0 1 get live-out? ] unit-test -[ t ] [ V int-regs 1 1 get live-out? ] unit-test -[ f ] [ V int-regs 2 1 get live-out? ] unit-test +[ t ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test -[ t ] [ V int-regs 0 2 get live-in? ] unit-test -[ f ] [ V int-regs 1 2 get live-in? ] unit-test -[ f ] [ V int-regs 2 2 get live-in? ] unit-test +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test -[ t ] [ V int-regs 0 2 get live-out? ] unit-test -[ f ] [ V int-regs 1 2 get live-out? ] unit-test -[ f ] [ V int-regs 2 2 get live-out? ] unit-test +[ f ] [ 0 3 get live-in? ] unit-test +[ t ] [ 1 3 get live-in? ] unit-test +[ f ] [ 2 3 get live-in? ] unit-test -[ f ] [ V int-regs 0 3 get live-in? ] unit-test -[ t ] [ V int-regs 1 3 get live-in? ] unit-test -[ f ] [ V int-regs 2 3 get live-in? ] unit-test +[ f ] [ 0 3 get live-out? ] unit-test +[ f ] [ 1 3 get live-out? ] unit-test +[ f ] [ 2 3 get live-out? ] unit-test -[ f ] [ V int-regs 0 3 get live-out? ] unit-test -[ t ] [ V int-regs 1 3 get live-out? ] unit-test -[ f ] [ V int-regs 2 3 get live-out? ] unit-test +[ f ] [ 0 4 get live-in? ] unit-test +[ f ] [ 1 4 get live-in? ] unit-test +[ f ] [ 2 4 get live-in? ] unit-test -[ f ] [ V int-regs 0 4 get live-in? ] unit-test -[ f ] [ V int-regs 1 4 get live-in? ] unit-test -[ f ] [ V int-regs 2 4 get live-in? ] unit-test - -[ f ] [ V int-regs 0 4 get live-out? ] unit-test -[ f ] [ V int-regs 1 4 get live-out? ] unit-test -[ f ] [ V int-regs 2 4 get live-out? ] unit-test +[ f ] [ 0 4 get live-out? ] unit-test +[ f ] [ 1 4 get live-out? ] unit-test +[ f ] [ 2 4 get live-out? ] unit-test ! This is the CFG in Figure 3 from the paper +V{ } 0 test-bb V{ } 1 test-bb +0 1 edge V{ } 2 test-bb 1 2 edge 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 } } 3 test-bb V{ } 11 test-bb 2 { 3 11 } edges V{ - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } } 4 test-bb V{ } 8 test-bb 3 { 8 4 } edges V{ - T{ ##replace f V int-regs 1 D 0 } + T{ ##replace f 1 D 0 } } 9 test-bb 8 9 edge V{ - T{ ##replace f V int-regs 2 D 0 } + T{ ##replace f 2 D 0 } } 5 test-bb 4 5 edge V{ } 10 test-bb @@ -160,9 +164,7 @@ V{ } 7 test-bb 10 8 edge 7 2 edge -cfg new 1 get >>entry 0 set -[ ] [ 0 get compute-predecessors drop ] unit-test -[ ] [ 0 get precompute-liveness ] unit-test +[ ] [ test-liveness ] unit-test [ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test [ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test @@ -200,92 +202,90 @@ cfg new 1 get >>entry 0 set [ f ] [ 10 get back-edge-target? ] unit-test [ f ] [ 11 get back-edge-target? ] unit-test -[ f ] [ 1 11 [a,b] [ get phi-outs get at ] any? ] unit-test +[ f ] [ 0 1 get live-in? ] unit-test +[ f ] [ 1 1 get live-in? ] unit-test +[ f ] [ 2 1 get live-in? ] unit-test -[ f ] [ V int-regs 0 1 get live-in? ] unit-test -[ f ] [ V int-regs 1 1 get live-in? ] unit-test -[ f ] [ V int-regs 2 1 get live-in? ] unit-test +[ f ] [ 0 1 get live-out? ] unit-test +[ f ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test -[ f ] [ V int-regs 0 1 get live-out? ] unit-test -[ f ] [ V int-regs 1 1 get live-out? ] unit-test -[ f ] [ V int-regs 2 1 get live-out? ] unit-test +[ f ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test -[ f ] [ V int-regs 0 2 get live-in? ] unit-test -[ f ] [ V int-regs 1 2 get live-in? ] unit-test -[ f ] [ V int-regs 2 2 get live-in? ] unit-test +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test -[ f ] [ V int-regs 0 2 get live-out? ] unit-test -[ f ] [ V int-regs 1 2 get live-out? ] unit-test -[ f ] [ V int-regs 2 2 get live-out? ] unit-test +[ f ] [ 0 3 get live-in? ] unit-test +[ f ] [ 1 3 get live-in? ] unit-test +[ f ] [ 2 3 get live-in? ] unit-test -[ f ] [ V int-regs 0 3 get live-in? ] unit-test -[ f ] [ V int-regs 1 3 get live-in? ] unit-test -[ f ] [ V int-regs 2 3 get live-in? ] unit-test +[ t ] [ 0 3 get live-out? ] unit-test +[ t ] [ 1 3 get live-out? ] unit-test +[ t ] [ 2 3 get live-out? ] unit-test -[ t ] [ V int-regs 0 3 get live-out? ] unit-test -[ t ] [ V int-regs 1 3 get live-out? ] unit-test -[ t ] [ V int-regs 2 3 get live-out? ] unit-test +[ t ] [ 0 4 get live-in? ] unit-test +[ f ] [ 1 4 get live-in? ] unit-test +[ t ] [ 2 4 get live-in? ] unit-test -[ t ] [ V int-regs 0 4 get live-in? ] unit-test -[ f ] [ V int-regs 1 4 get live-in? ] unit-test -[ t ] [ V int-regs 2 4 get live-in? ] unit-test +[ f ] [ 0 4 get live-out? ] unit-test +[ f ] [ 1 4 get live-out? ] unit-test +[ t ] [ 2 4 get live-out? ] unit-test -[ f ] [ V int-regs 0 4 get live-out? ] unit-test -[ f ] [ V int-regs 1 4 get live-out? ] unit-test -[ t ] [ V int-regs 2 4 get live-out? ] unit-test +[ f ] [ 0 5 get live-in? ] unit-test +[ f ] [ 1 5 get live-in? ] unit-test +[ t ] [ 2 5 get live-in? ] unit-test -[ f ] [ V int-regs 0 5 get live-in? ] unit-test -[ f ] [ V int-regs 1 5 get live-in? ] unit-test -[ t ] [ V int-regs 2 5 get live-in? ] unit-test +[ f ] [ 0 5 get live-out? ] unit-test +[ f ] [ 1 5 get live-out? ] unit-test +[ t ] [ 2 5 get live-out? ] unit-test -[ f ] [ V int-regs 0 5 get live-out? ] unit-test -[ f ] [ V int-regs 1 5 get live-out? ] unit-test -[ t ] [ V int-regs 2 5 get live-out? ] unit-test +[ f ] [ 0 6 get live-in? ] unit-test +[ f ] [ 1 6 get live-in? ] unit-test +[ t ] [ 2 6 get live-in? ] unit-test -[ f ] [ V int-regs 0 6 get live-in? ] unit-test -[ f ] [ V int-regs 1 6 get live-in? ] unit-test -[ t ] [ V int-regs 2 6 get live-in? ] unit-test +[ f ] [ 0 6 get live-out? ] unit-test +[ f ] [ 1 6 get live-out? ] unit-test +[ t ] [ 2 6 get live-out? ] unit-test -[ f ] [ V int-regs 0 6 get live-out? ] unit-test -[ f ] [ V int-regs 1 6 get live-out? ] unit-test -[ t ] [ V int-regs 2 6 get live-out? ] unit-test +[ f ] [ 0 7 get live-in? ] unit-test +[ f ] [ 1 7 get live-in? ] unit-test +[ f ] [ 2 7 get live-in? ] unit-test -[ f ] [ V int-regs 0 7 get live-in? ] unit-test -[ f ] [ V int-regs 1 7 get live-in? ] unit-test -[ f ] [ V int-regs 2 7 get live-in? ] unit-test +[ f ] [ 0 7 get live-out? ] unit-test +[ f ] [ 1 7 get live-out? ] unit-test +[ f ] [ 2 7 get live-out? ] unit-test -[ f ] [ V int-regs 0 7 get live-out? ] unit-test -[ f ] [ V int-regs 1 7 get live-out? ] unit-test -[ f ] [ V int-regs 2 7 get live-out? ] unit-test +[ f ] [ 0 8 get live-in? ] unit-test +[ t ] [ 1 8 get live-in? ] unit-test +[ t ] [ 2 8 get live-in? ] unit-test -[ f ] [ V int-regs 0 8 get live-in? ] unit-test -[ t ] [ V int-regs 1 8 get live-in? ] unit-test -[ t ] [ V int-regs 2 8 get live-in? ] unit-test +[ f ] [ 0 8 get live-out? ] unit-test +[ t ] [ 1 8 get live-out? ] unit-test +[ t ] [ 2 8 get live-out? ] unit-test -[ f ] [ V int-regs 0 8 get live-out? ] unit-test -[ t ] [ V int-regs 1 8 get live-out? ] unit-test -[ t ] [ V int-regs 2 8 get live-out? ] unit-test +[ f ] [ 0 9 get live-in? ] unit-test +[ t ] [ 1 9 get live-in? ] unit-test +[ t ] [ 2 9 get live-in? ] unit-test -[ f ] [ V int-regs 0 9 get live-in? ] unit-test -[ t ] [ V int-regs 1 9 get live-in? ] unit-test -[ t ] [ V int-regs 2 9 get live-in? ] unit-test +[ f ] [ 0 9 get live-out? ] unit-test +[ t ] [ 1 9 get live-out? ] unit-test +[ t ] [ 2 9 get live-out? ] unit-test -[ f ] [ V int-regs 0 9 get live-out? ] unit-test -[ t ] [ V int-regs 1 9 get live-out? ] unit-test -[ t ] [ V int-regs 2 9 get live-out? ] unit-test +[ f ] [ 0 10 get live-in? ] unit-test +[ t ] [ 1 10 get live-in? ] unit-test +[ t ] [ 2 10 get live-in? ] unit-test -[ f ] [ V int-regs 0 10 get live-in? ] unit-test -[ t ] [ V int-regs 1 10 get live-in? ] unit-test -[ t ] [ V int-regs 2 10 get live-in? ] unit-test +[ f ] [ 0 10 get live-out? ] unit-test +[ t ] [ 1 10 get live-out? ] unit-test +[ t ] [ 2 10 get live-out? ] unit-test -[ f ] [ V int-regs 0 10 get live-out? ] unit-test -[ t ] [ V int-regs 1 10 get live-out? ] unit-test -[ t ] [ V int-regs 2 10 get live-out? ] unit-test +[ f ] [ 0 11 get live-in? ] unit-test +[ f ] [ 1 11 get live-in? ] unit-test +[ f ] [ 2 11 get live-in? ] unit-test -[ f ] [ V int-regs 0 11 get live-in? ] unit-test -[ f ] [ V int-regs 1 11 get live-in? ] unit-test -[ f ] [ V int-regs 2 11 get live-in? ] unit-test - -[ f ] [ V int-regs 0 11 get live-out? ] unit-test -[ f ] [ V int-regs 1 11 get live-out? ] unit-test -[ f ] [ V int-regs 2 11 get live-out? ] unit-test +[ f ] [ 0 11 get live-out? ] unit-test +[ f ] [ 1 11 get live-out? ] unit-test +[ f ] [ 2 11 get live-out? ] unit-test diff --git a/basis/compiler/cfg/ssa/liveness/liveness.factor b/basis/compiler/cfg/ssa/liveness/liveness.factor index f2a195eb24..1ed6010dbe 100644 --- a/basis/compiler/cfg/ssa/liveness/liveness.factor +++ b/basis/compiler/cfg/ssa/liveness/liveness.factor @@ -21,10 +21,6 @@ SYMBOL: R_q-sets ! Targets of back edges SYMBOL: back-edge-targets -! hashtable of nodes => sets of vregs, where the vregs are inputs -! to phi nodes in a successor node -SYMBOL: phi-outs - : T_q ( q -- T_q ) T_q-sets get at ; @@ -34,9 +30,6 @@ SYMBOL: phi-outs : back-edge-target? ( block -- ? ) back-edge-targets get key? ; -: phi-out? ( vreg node -- ? ) - phi-outs get at key? ; - : next-R_q ( q -- R_q ) [ ] [ successors>> ] [ number>> ] tri '[ number>> _ >= ] filter @@ -52,27 +45,14 @@ SYMBOL: phi-outs [ back-edge-targets get conjoin ] [ drop ] if ] each ; -: set-phi-out ( block vreg -- ) - swap phi-outs get [ drop H{ } clone ] cache conjoin ; - -: set-phi-outs ( q -- ) - instructions>> [ - dup ##phi? [ - inputs>> [ set-phi-out ] assoc-each - ] [ drop ] if - ] each ; - : init-R_q ( -- ) H{ } clone R_q-sets set - H{ } clone back-edge-targets set - H{ } clone phi-outs set ; + H{ } clone back-edge-targets set ; : compute-R_q ( cfg -- ) init-R_q post-order [ - [ set-R_q ] - [ set-back-edges ] - [ set-phi-outs ] tri + [ set-R_q ] [ set-back-edges ] bi ] each ; ! This algorithm for computing T_q uses equation (1) @@ -100,13 +80,7 @@ SYMBOL: phi-outs PRIVATE> : precompute-liveness ( cfg -- ) - ! Maybe dominance and def-use should be called before this, separately - { - [ compute-dominance ] - [ compute-def-use ] - [ compute-R_q ] - [ compute-T_q ] - } cleave ; + [ compute-R_q ] [ compute-T_q ] bi ; [let | def [ vreg def-of ] | { { [ node def eq? ] [ vreg uses-of def only? not ] } - { [ vreg node phi-out? ] [ t ] } { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } [ f ] } cond diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 9eb6d27521..4b071cb43c 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -9,41 +9,27 @@ TUPLE: stack-frame { return integer } { total-size integer } { gc-root-size integer } -spill-counts ; +{ spill-area-size integer } ; ! Stack frame utilities : param-base ( -- n ) stack-frame get [ params>> ] [ return>> ] bi + ; -: spill-float-offset ( n -- offset ) - double-float-regs reg-size * ; - -: spill-integer-base ( -- n ) - stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size * +: spill-offset ( n -- offset ) param-base + ; -: spill-integer-offset ( n -- offset ) - cells spill-integer-base + ; - -: spill-area-size ( stack-frame -- n ) - spill-counts>> [ swap reg-size * ] { } assoc>map sum ; - : gc-root-base ( -- n ) - stack-frame get spill-area-size - param-base + ; + stack-frame get spill-area-size>> param-base + ; : gc-root-offset ( n -- n' ) gc-root-base + ; -: gc-roots-size ( live-values -- n ) - keys [ reg-class>> reg-size ] sigma ; - : (stack-frame-size) ( stack-frame -- n ) [ { - [ spill-area-size ] - [ gc-root-size>> ] [ params>> ] [ return>> ] + [ gc-root-size>> ] + [ spill-area-size>> ] } cleave ] sum-outputs ; diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index 094b3c5f1e..ca81c69bc0 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -1,20 +1,31 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs kernel fry accessors sequences make math +USING: namespaces assocs kernel fry accessors sequences make math locals combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local -compiler.cfg.stacks.global compiler.cfg.stacks.height ; +compiler.cfg.stacks.global compiler.cfg.stacks.height +compiler.cfg.predecessors ; IN: compiler.cfg.stacks.finalize ! This pass inserts peeks and replaces. -: inserting-peeks ( from to -- assoc ) - peek-in swap [ peek-out ] [ avail-out ] bi - assoc-union assoc-diff ; +:: inserting-peeks ( from to -- assoc ) + ! A peek is inserted on an edge if the destination anticipates + ! the stack location, the source does not anticipate it and + ! it is not available from the source in a register. + to anticip-in + from anticip-out from avail-out assoc-union + assoc-diff ; -: inserting-replaces ( from to -- assoc ) - [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* - assoc-union assoc-diff ; +:: inserting-replaces ( from to -- assoc ) + ! A replace is inserted on an edge if two conditions hold: + ! - the location is not dead at the destination, OR + ! the location is live at the destination but not available + ! at the destination + ! - the location is pending in the source but not the destination + from pending-out to pending-in assoc-diff + to dead-in to live-in to anticip-in assoc-diff assoc-diff + assoc-diff ; : each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline @@ -33,7 +44,7 @@ ERROR: bad-peek dst loc ; ! If both blocks are subroutine calls, don't bother ! computing anything. 2dup [ kill-block? ] both? [ 2drop ] [ - 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make + 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ] if ; @@ -41,5 +52,8 @@ ERROR: bad-peek dst loc ; [ predecessors>> ] keep '[ _ visit-edge ] each ; : finalize-stack-shuffling ( cfg -- cfg' ) + needs-predecessors + dup [ visit-block ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor index 2062815787..30a999064a 100644 --- a/basis/compiler/cfg/stacks/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -4,36 +4,56 @@ USING: assocs kernel combinators compiler.cfg.dataflow-analysis compiler.cfg.stacks.local ; IN: compiler.cfg.stacks.global -! Peek analysis. Peek-in is the set of all locations anticipated at -! the start of a basic block. -BACKWARD-ANALYSIS: peek +: transfer-peeked-locs ( assoc bb -- assoc' ) + [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ; -M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ; +! A stack location is anticipated at a location if every path from +! the location to an exit block will read the stack location +! before writing it. +BACKWARD-ANALYSIS: anticip -! Replace analysis. Replace-in is the set of all locations which -! will be overwritten at some point after the start of a basic block. -FORWARD-ANALYSIS: replace +M: anticip-analysis transfer-set drop transfer-peeked-locs ; -M: replace-analysis transfer-set drop replace-set assoc-union ; +! A stack location is live at a location if some path from +! the location to an exit block will read the stack location +! before writing it. +BACKWARD-ANALYSIS: live -! Availability analysis. Avail-out is the set of all locations -! in registers at the end of a basic block. +M: live-analysis transfer-set drop transfer-peeked-locs ; + +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 +! register. FORWARD-ANALYSIS: avail -M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ; +M: avail-analysis transfer-set + drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ; -! Kill analysis. Kill-in is the set of all locations -! which are going to be overwritten. -BACKWARD-ANALYSIS: kill +! A stack location is pending at a location if all paths from +! the entry block to the location write the location. +FORWARD-ANALYSIS: pending -M: kill-analysis transfer-set drop kill-set assoc-union ; +M: pending-analysis transfer-set + drop replace-set assoc-union ; + +! A stack location is dead at a location if no paths from the +! location to the exit block read the location before writing it. +BACKWARD-ANALYSIS: dead + +M: dead-analysis transfer-set + drop + [ kill-set assoc-union ] + [ replace-set assoc-union ] bi ; ! Main word : compute-global-sets ( cfg -- cfg' ) { - [ compute-peek-sets ] - [ compute-replace-sets ] + [ compute-anticip-sets ] + [ compute-live-sets ] + [ compute-pending-sets ] + [ compute-dead-sets ] [ compute-avail-sets ] - [ compute-kill-sets ] [ ] - } cleave ; \ No newline at end of file + } cleave ; diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index 4d3ed36be9..4878dbe3ab 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -10,14 +10,19 @@ compiler.cfg.stacks.height compiler.cfg.parallel-copy ; IN: compiler.cfg.stacks.local -! Local stack analysis. We build local peek and replace sets for every basic -! block while constructing the CFG. +! Local stack analysis. We build three sets for every basic block +! in the CFG: +! - peek-set: all stack locations that the block reads before writing +! - replace-set: all stack locations that the block writes +! - kill-set: all stack locations which become unavailable after the +! block ends because of the stack height being decremented +! This is done while constructing the CFG. SYMBOLS: peek-sets replace-sets kill-sets ; SYMBOL: locs>vregs -: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ; : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; TUPLE: current-height @@ -80,9 +85,8 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : compute-local-kill-set ( -- assoc ) basic-block get current-height get [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - ] with map ] - [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - ] with map ] - [ drop local-replace-set get at ] 2tri - [ append unique dup ] dip update ; + [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - ] with map ] 2bi + append unique ; : begin-local-analysis ( -- ) H{ } clone local-peek-set set diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index 1896b0a7fb..ce673ba5bb 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -18,7 +18,6 @@ IN: compiler.cfg.stacks : end-stack-analysis ( -- ) cfg get - compute-predecessors compute-global-sets finalize-stack-shuffling drop ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor index 39b2f7747c..61c3cd67d1 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor @@ -1,12 +1,11 @@ -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 - compute-predecessors compute-uninitialized-sets ; V{ @@ -14,14 +13,14 @@ V{ } 0 test-bb V{ - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##replace f V int-regs 0 D 2 } + T{ ##replace f 0 D 0 } + T{ ##replace f 0 D 1 } + T{ ##replace f 0 D 2 } T{ ##inc-r f 1 } } 1 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##inc-d f 1 } } 2 test-bb diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index ee60c4bd7a..ce0e98de5f 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -52,7 +52,7 @@ M: insn visit-insn drop ; : finish ( -- pair ) ds-loc get rs-loc get 2array ; : (join-sets) ( seq1 seq2 -- seq ) - 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ; + 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; : (uninitialized-locs) ( seq quot -- seq' ) [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline @@ -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 [ @@ -73,4 +73,4 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair ) [ [ ] (uninitialized-locs) ] [ [ ] (uninitialized-locs) ] bi* append - ] when ; \ No newline at end of file + ] when ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 3dbdf148e9..810b901013 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -10,7 +10,7 @@ compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.tco -! Tail call optimization. You must run compute-predecessors after this +! Tail call optimization. : return? ( bb -- ? ) skip-empty-blocks @@ -63,6 +63,6 @@ IN: compiler.cfg.tco ] [ drop ] if ; : optimize-tail-calls ( cfg -- cfg' ) - dup cfg set dup [ optimize-tail-call ] each-basic-block - cfg-changed ; \ No newline at end of file + + cfg-changed predecessors-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor index 0717f1c536..09d88a2959 100644 --- a/basis/compiler/cfg/two-operand/two-operand-tests.factor +++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor @@ -1,38 +1,52 @@ -IN: compiler.cfg.two-operand.tests -USING: compiler.cfg.two-operand compiler.cfg.instructions +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 [ V{ - T{ ##copy f V int-regs 1 V int-regs 2 } - T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 } + T{ ##copy f 1 2 int-rep } + T{ ##sub f 1 1 3 } } ] [ + H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + } clone representations set { - T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 } + T{ ##sub f 1 2 3 } } (convert-two-operand) ] unit-test [ V{ - T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + T{ ##copy f 1 2 double-float-rep } + T{ ##sub-float f 1 1 3 } } ] [ + H{ + { 1 double-float-rep } + { 2 double-float-rep } + { 3 double-float-rep } + } clone representations set { - T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + T{ ##sub-float f 1 2 3 } } (convert-two-operand) ] unit-test [ V{ - T{ ##copy f V int-regs 4 V int-regs 1 } - T{ ##copy f V int-regs 1 V int-regs 2 } - T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 } + T{ ##copy f 1 2 double-float-rep } + T{ ##mul-float f 1 1 1 } } ] [ + H{ + { 1 double-float-rep } + { 2 double-float-rep } + } clone representations set { - T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 } + T{ ##mul-float f 1 2 2 } } (convert-two-operand) ] unit-test diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 7a8b160acd..1705355842 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -5,27 +5,17 @@ compiler.cfg.registers compiler.cfg.instructions compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand -! This pass runs after SSA coalescing and normalizes instructions -! to fit the x86 two-address scheme. Possibilities are: - -! 1) x = x op y -! 2) x = y op x -! 3) x = y op z - -! In case 1, there is nothing to do. - -! In case 2, we convert to -! z = y -! z = z op x -! x = z - -! In case 3, we convert to +! This pass runs before SSA coalescing and normalizes instructions +! to fit the x86 two-address scheme. Since the input is in SSA, +! it suffices to convert +! +! x = y op z +! +! to +! ! x = y ! x = x op z - -! In case 2 and case 3, linear scan coalescing will eliminate a -! copy if the value y is never used again. - +! ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm ! since x86 has LEA and IMUL instructions which are effectively ! three-operand addition and multiplication, respectively. @@ -54,42 +44,19 @@ UNION: two-operand-insn GENERIC: convert-two-operand* ( insn -- ) : emit-copy ( dst src -- ) - dup reg-class>> { - { int-regs [ ##copy ] } - { double-float-regs [ ##copy-float ] } - } case ; inline - -: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline - -: case-1 ( insn -- ) , ; inline - -: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline - -: case-2 ( insn -- ) - dup dst>> reg-class>> next-vreg - [ swap src2>> emit-copy ] - [ drop [ src2>> ] [ src1>> ] bi emit-copy ] - [ >>src2 dup dst>> >>src1 , ] - 2tri ; inline - -: case-3 ( insn -- ) - [ [ dst>> ] [ src1>> ] bi emit-copy ] - [ dup dst>> >>src1 , ] - bi ; inline + dup rep-of ##copy ; inline M: two-operand-insn convert-two-operand* - { - { [ dup case-1? ] [ case-1 ] } - { [ dup case-2? ] [ case-2 ] } - [ case-3 ] - } cond ; inline + [ [ dst>> ] [ src1>> ] bi emit-copy ] + [ + dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when + dup dst>> >>src1 , + ] bi ; M: ##not convert-two-operand* - dup [ dst>> ] [ src>> ] bi = [ - [ [ dst>> ] [ src>> ] bi ##copy ] - [ dup dst>> >>src ] - bi - ] unless , ; + [ [ dst>> ] [ src>> ] bi emit-copy ] + [ dup dst>> >>src , ] + bi ; M: insn convert-two-operand* , ; diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor index cc98d08042..d480ad97d1 100644 --- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -19,4 +19,5 @@ IN: compiler.cfg.useless-conditionals dup [ dup delete-conditional? [ delete-conditional ] [ drop ] if ] each-basic-block - cfg-changed ; + + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 9246084325..6d68bca4b9 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -69,6 +69,10 @@ SYMBOL: visited [ instructions>> ] dip '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline +: each-non-phi ( bb quot: ( insn -- ) -- ) + [ instructions>> ] dip + '[ dup ##phi? [ drop ] _ if ] each ; inline + : predecessor ( bb -- pred ) predecessors>> first ; inline diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 4b8ee2a1ae..50f809cc99 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -4,7 +4,7 @@ USING: accessors combinators combinators.short-circuit arrays fry kernel layouts math namespaces sequences cpu.architecture math.bitwise math.order classes vectors compiler.cfg -compiler.cfg.hats +compiler.cfg.registers compiler.cfg.comparisons compiler.cfg.instructions compiler.cfg.value-numbering.expressions @@ -77,7 +77,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi - i \ ##compare-imm new-insn ; + next-vreg \ ##compare-imm new-insn ; : rewrite-redundant-comparison? ( insn -- ? ) { @@ -88,9 +88,9 @@ M: ##compare-imm rewrite-tagged-comparison : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { - { \ ##compare [ >compare-expr< i \ ##compare new-insn ] } - { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] } - { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] } + { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] } + { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] } + { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] } } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; @@ -169,7 +169,7 @@ M: ##compare-branch rewrite ] dip swap-compare [ vreg>constant ] dip - i \ ##compare-imm new-insn ; inline + next-vreg \ ##compare-imm new-insn ; inline : >boolean-insn ( insn ? -- insn' ) [ dst>> ] dip diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 6bd84021b3..b805d7834c 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -9,22 +9,14 @@ IN: compiler.cfg.value-numbering.simplify ! Return value of f means we didn't simplify. GENERIC: simplify* ( expr -- vn/expr/f ) -: simplify-unbox ( in boxer -- vn/expr/f ) - over op>> eq? [ in>> ] [ drop f ] if ; inline - -: simplify-unbox-float ( in -- vn/expr/f ) - \ ##box-float simplify-unbox ; inline - : simplify-unbox-alien ( in -- vn/expr/f ) - \ ##box-alien simplify-unbox ; inline + dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline M: unary-expr simplify* #! Note the copy propagation: a copy always simplifies to #! its source VN. [ in>> vn>expr ] [ op>> ] bi { { \ ##copy [ ] } - { \ ##copy-float [ ] } - { \ ##unbox-float [ simplify-unbox-float ] } { \ ##unbox-alien [ simplify-unbox-alien ] } { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] } [ 2drop f ] diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 519cea617a..f3c950679a 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,10 +1,11 @@ -IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons cpu.architecture tools.test kernel math combinators.short-circuit -accessors sequences compiler.cfg.predecessors locals -compiler.cfg.dce compiler.cfg.ssa.destruction -compiler.cfg assocs vectors arrays layouts namespaces ; +accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce +compiler.cfg.ssa.destruction compiler.cfg.loop-detection +compiler.cfg.representations compiler.cfg assocs vectors arrays +layouts namespaces ; +IN: compiler.cfg.value-numbering.tests : trim-temps ( insns -- insns ) [ @@ -18,853 +19,853 @@ compiler.cfg assocs vectors arrays layouts namespaces ; ! Folding constants together [ { - T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 -0.0 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 -0.0 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } value-numbering-step ] unit-test [ { - T{ ##load-reference f V int-regs 0 0.0 } - T{ ##copy f V int-regs 1 V int-regs 0 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 0.0 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } value-numbering-step ] unit-test [ { - T{ ##load-reference f V int-regs 0 t } - T{ ##copy f V int-regs 1 V int-regs 0 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 t } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-reference f V int-regs 0 t } - T{ ##load-reference f V int-regs 1 t } - T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##load-reference f 0 t } + T{ ##load-reference f 1 t } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } value-numbering-step ] unit-test ! Compare propagation [ { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##copy f V int-regs 6 V int-regs 4 } - T{ ##replace f V int-regs 6 D 0 } + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc> } + T{ ##copy f 6 4 any-rep } + T{ ##replace f 6 D 0 } } ] [ { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } - T{ ##replace f V int-regs 6 D 0 } + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc> } + T{ ##compare-imm f 6 4 5 cc/= } + T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test [ { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 6 D 0 } + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc<= } + T{ ##compare f 6 2 1 cc> } + T{ ##replace f 6 D 0 } } ] [ { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } - T{ ##replace f V int-regs 6 D 0 } + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc<= } + T{ ##compare-imm f 6 4 5 cc= } + T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test [ { - T{ ##peek f V int-regs 8 D 0 } - T{ ##peek f V int-regs 9 D -1 } - T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } - T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } - T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= } - T{ ##replace f V int-regs 14 D 0 } + T{ ##peek f 8 D 0 } + T{ ##peek f 9 D -1 } + T{ ##unbox-float f 10 8 } + T{ ##unbox-float f 11 9 } + T{ ##compare-float f 12 10 11 cc< } + T{ ##compare-float f 14 10 11 cc>= } + T{ ##replace f 14 D 0 } } ] [ { - T{ ##peek f V int-regs 8 D 0 } - T{ ##peek f V int-regs 9 D -1 } - T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } - T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } - T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } - T{ ##replace f V int-regs 14 D 0 } + T{ ##peek f 8 D 0 } + T{ ##peek f 9 D -1 } + T{ ##unbox-float f 10 8 } + T{ ##unbox-float f 11 9 } + T{ ##compare-float f 12 10 11 cc< } + T{ ##compare-imm f 14 12 5 cc= } + T{ ##replace f 14 D 0 } } value-numbering-step trim-temps ] unit-test [ { - T{ ##peek f V int-regs 29 D -1 } - T{ ##peek f V int-regs 30 D -2 } - T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= } + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare f 33 29 30 cc<= } + T{ ##compare-branch f 29 30 cc<= } } ] [ { - T{ ##peek f V int-regs 29 D -1 } - T{ ##peek f V int-regs 30 D -2 } - T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-imm-branch f V int-regs 33 5 cc/= } + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare f 33 29 30 cc<= } + T{ ##compare-imm-branch f 33 5 cc/= } } value-numbering-step trim-temps ] unit-test ! Immediate operand conversion [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 1 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 -100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 -100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##sub f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##sub f 1 0 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 1 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 1 D 0 } - T{ ##shl-imm f V int-regs 2 V int-regs 1 3 } + T{ ##peek f 1 D 0 } + T{ ##shl-imm f 2 1 3 } } ] [ { - T{ ##peek f V int-regs 1 D 0 } - T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } + T{ ##peek f 1 D 0 } + T{ ##mul-imm f 2 1 8 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 1 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 1 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 0 1 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 1 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm f 2 0 100 cc<= } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare f 2 0 1 cc<= } } value-numbering-step trim-temps ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm f 2 0 100 cc>= } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare f 2 1 0 cc<= } } value-numbering-step trim-temps ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-imm-branch f V int-regs 0 100 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm-branch f 0 100 cc<= } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-branch f 0 1 cc<= } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-imm-branch f V int-regs 0 100 cc>= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm-branch f 0 100 cc>= } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-branch f 1 0 cc<= } } value-numbering-step trim-temps ] unit-test ! Reassociation [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add-imm f V int-regs 4 V int-regs 0 150 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 150 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##add f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add-imm f V int-regs 4 V int-regs 0 150 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 150 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##add f 4 3 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add-imm f V int-regs 4 V int-regs 0 50 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 50 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##sub f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##add-imm f V int-regs 2 V int-regs 0 -100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##add-imm f V int-regs 4 V int-regs 0 -150 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 -100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 -150 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##sub f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##sub f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##mul-imm f 4 0 5000 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##mul f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##mul-imm f 4 0 5000 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##mul f 4 3 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##and-imm f V int-regs 4 V int-regs 0 32 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##and-imm f 4 0 32 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##and f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##and-imm f V int-regs 4 V int-regs 0 32 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##and-imm f 4 0 32 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##and f 4 3 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##or-imm f V int-regs 4 V int-regs 0 118 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##or-imm f 4 0 118 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##or f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##or-imm f V int-regs 4 V int-regs 0 118 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##or-imm f 4 0 118 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##or f 4 3 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##xor-imm f V int-regs 4 V int-regs 0 86 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##xor-imm f 4 0 86 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##xor f 4 2 3 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##xor-imm f V int-regs 4 V int-regs 0 86 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##xor-imm f 4 0 86 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } - T{ ##load-immediate f V int-regs 3 50 } - T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##xor f 4 3 2 } } value-numbering-step ] unit-test ! Simplification [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##load-immediate f V int-regs 2 0 } - T{ ##copy f V int-regs 3 V int-regs 0 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##add f 3 0 2 } + T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##load-immediate f V int-regs 2 0 } - T{ ##copy f V int-regs 3 V int-regs 0 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } - T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##sub f 3 0 2 } + T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##load-immediate f V int-regs 2 0 } - T{ ##copy f V int-regs 3 V int-regs 0 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } - T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##or f 3 0 2 } + T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##load-immediate f V int-regs 2 0 } - T{ ##copy f V int-regs 3 V int-regs 0 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } - T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 } - T{ ##replace f V int-regs 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##xor f 3 0 2 } + T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##copy f V int-regs 2 V int-regs 0 } - T{ ##replace f V int-regs 2 D 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } - T{ ##replace f V int-regs 2 D 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##mul f 2 0 1 } + T{ ##replace f 2 D 0 } } value-numbering-step ] unit-test ! Constant folding [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##load-immediate f V int-regs 3 4 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 4 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##add f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##load-immediate f V int-regs 3 -2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 -2 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##sub f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##load-immediate f V int-regs 3 6 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 6 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##mul f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 1 } - T{ ##load-immediate f V int-regs 3 0 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##load-immediate f 3 0 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 1 } - T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##and f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 1 } - T{ ##load-immediate f V int-regs 3 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##load-immediate f 3 3 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 1 } - T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##or f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##load-immediate f V int-regs 3 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 1 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 2 } - T{ ##load-immediate f V int-regs 2 3 } - T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##xor f 3 1 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 3 8 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 3 8 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 1 } - T{ ##shl-imm f V int-regs 3 V int-regs 1 3 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##shl-imm f 3 1 3 } } value-numbering-step ] unit-test cell 8 = [ [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 -1 } - T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##load-immediate f 3 HEX: ffffffffffff } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 -1 } - T{ ##shr-imm f V int-regs 3 V int-regs 1 16 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##shr-imm f 3 1 16 } } value-numbering-step ] unit-test ] when [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 -8 } - T{ ##load-immediate f V int-regs 3 -4 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -8 } + T{ ##load-immediate f 3 -4 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 -8 } - T{ ##sar-imm f V int-regs 3 V int-regs 1 1 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -8 } + T{ ##sar-imm f 3 1 1 } } value-numbering-step ] unit-test cell 8 = [ [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 65536 } - T{ ##load-immediate f V int-regs 2 140737488355328 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 65536 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 65536 } - T{ ##shl-imm f V int-regs 2 V int-regs 1 31 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 65536 } + T{ ##shl-imm f 2 1 31 } + T{ ##add f 3 0 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 2 140737488355328 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 2 140737488355328 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 2 2147483647 } - T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 } - T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 2147483647 } + T{ ##add-imm f 3 0 2147483647 } + T{ ##add-imm f 4 3 2147483647 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 2 2147483647 } - T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } - T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 2147483647 } + T{ ##add f 3 0 2 } + T{ ##add f 4 3 2 } } value-numbering-step ] unit-test ] when @@ -872,129 +873,129 @@ cell 8 = [ ! Branch folding [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##load-immediate f V int-regs 3 5 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 3 5 } } ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc= } } value-numbering-step ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##load-reference f V int-regs 3 t } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-reference f 3 t } } ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc/= } } value-numbering-step ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##load-reference f V int-regs 3 t } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-reference f 3 t } } ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc< } } value-numbering-step ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##load-immediate f V int-regs 3 5 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 3 5 } } ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 2 1 cc< } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 5 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc< } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-reference f V int-regs 1 t } + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc<= } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 5 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc> } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-reference f V int-regs 1 t } + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc>= } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-immediate f V int-regs 1 5 } + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc/= } } value-numbering-step ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-reference f V int-regs 1 t } + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } } ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc= } } value-numbering-step ] unit-test @@ -1005,154 +1006,154 @@ cell 8 = [ [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } T{ ##branch } } 1 ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc= } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } T{ ##branch } } 0 ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc/= } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } T{ ##branch } } 0 ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc< } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } T{ ##branch } } 1 ] [ { - T{ ##load-immediate f V int-regs 1 1 } - T{ ##load-immediate f V int-regs 2 2 } - T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 2 1 cc< } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 1 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc< } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc<= } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 1 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc> } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc>= } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc= } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 1 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc/= } } test-branch-folding ] unit-test [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##load-reference f V int-regs 1 t } + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } T{ ##branch } } 0 ] [ { - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= } - T{ ##compare-imm-branch f V int-regs 1 5 cc/= } + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc<= } + T{ ##compare-imm-branch f 1 5 cc/= } } test-branch-folding ] unit-test @@ -1160,32 +1161,32 @@ cell 8 = [ V{ T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc< } } 1 test-bb V{ - T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f 1 1 } T{ ##branch } } 2 test-bb V{ - T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f 2 2 } T{ ##branch } } 3 test-bb V{ - T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } } - T{ ##replace f V int-regs 3 D 0 } + T{ ##phi f 3 H{ { 2 1 } { 3 2 } } } + T{ ##replace f 3 D 0 } T{ ##return } } 4 test-bb test-diamond [ ] [ - cfg new 0 get >>entry + cfg new 0 get >>entry dup cfg set value-numbering - compute-predecessors + select-representations destruct-ssa drop ] unit-test @@ -1196,40 +1197,38 @@ test-diamond [ 2 ] [ 4 get instructions>> length ] unit-test V{ - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f 0 D 0 } T{ ##branch } } 0 test-bb V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< } + T{ ##peek f 1 D 1 } + T{ ##compare-branch f 1 1 cc< } } 1 test-bb V{ - T{ ##copy f V int-regs 2 V int-regs 0 } + T{ ##copy f 2 0 any-rep } T{ ##branch } } 2 test-bb V{ - T{ ##phi f V int-regs 3 V{ } } + T{ ##phi f 3 V{ } } T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 3 D 0 } + T{ ##replace f 3 D 0 } T{ ##return } } 4 test-bb -1 get V int-regs 1 2array -2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs) +1 get 1 2array +2 get 0 2array 2array 3 get instructions>> first (>>inputs) test-diamond [ ] [ cfg new 0 get >>entry - compute-predecessors value-numbering - compute-predecessors eliminate-dead-code drop ] unit-test @@ -1241,52 +1240,52 @@ test-diamond V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ - T{ ##peek { dst V int-regs 15 } { loc D 0 } } - T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } } - T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } } - T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } } - T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } } + T{ ##peek { dst 15 } { loc D 0 } } + T{ ##copy { dst 16 } { src 15 } { rep any-rep } } + T{ ##copy { dst 17 } { src 15 } { rep any-rep } } + T{ ##copy { dst 18 } { src 15 } { rep any-rep } } + T{ ##copy { dst 19 } { src 15 } { rep any-rep } } T{ ##compare - { dst V int-regs 20 } - { src1 V int-regs 18 } - { src2 V int-regs 19 } + { dst 20 } + { src1 18 } + { src2 19 } { cc cc= } - { temp V int-regs 22 } + { temp 22 } } - T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } } + T{ ##copy { dst 21 } { src 20 } { rep any-rep } } T{ ##compare-imm-branch - { src1 V int-regs 21 } + { src1 21 } { src2 5 } { cc cc/= } } } 1 test-bb V{ - T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } } - T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } } - T{ ##load-reference { dst V int-regs 25 } { obj t } } + T{ ##copy { dst 23 } { src 15 } { rep any-rep } } + T{ ##copy { dst 24 } { src 15 } { rep any-rep } } + T{ ##load-reference { dst 25 } { obj t } } T{ ##branch } } 2 test-bb V{ - T{ ##replace { src V int-regs 25 } { loc D 0 } } + T{ ##replace { src 25 } { loc D 0 } } T{ ##epilogue } T{ ##return } } 3 test-bb V{ - T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } } - T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } } + T{ ##copy { dst 26 } { src 15 } { rep any-rep } } + T{ ##copy { dst 27 } { src 15 } { rep any-rep } } T{ ##add - { dst V int-regs 28 } - { src1 V int-regs 26 } - { src2 V int-regs 27 } + { dst 28 } + { src1 26 } + { src2 27 } } T{ ##branch } } 4 test-bb V{ - T{ ##replace { src V int-regs 28 } { loc D 0 } } + T{ ##replace { src 28 } { loc D 0 } } T{ ##epilogue } T{ ##return } } 5 test-bb diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index a249f71c02..689d1d32c6 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs kernel accessors sorting sets sequences +cpu.architecture compiler.cfg compiler.cfg.rpo compiler.cfg.instructions @@ -11,10 +12,11 @@ compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering -! Local value numbering. Predecessors must be recomputed after this +! Local value numbering. + : >copy ( insn -- insn/##copy ) dup dst>> dup vreg>vn vn>vreg - 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ; + 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ; : rewrite-loop ( insn -- insn' ) dup rewrite [ rewrite-loop ] [ ] ?if ; @@ -36,4 +38,6 @@ M: insn process-instruction [ process-instruction ] map ; : value-numbering ( cfg -- cfg' ) - [ value-numbering-step ] local-optimization cfg-changed ; + [ value-numbering-step ] local-optimization + + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/write-barrier/authors.txt b/basis/compiler/cfg/write-barrier/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/cfg/write-barrier/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index 14197bc3f7..dd010f0dbc 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,7 +1,9 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. 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 ; +compiler.cfg.utilities namespaces sequences ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) @@ -9,64 +11,132 @@ IN: compiler.cfg.write-barrier.tests [ V{ - T{ ##peek f V int-regs 4 D 0 f } - T{ ##allot f V int-regs 7 24 array V int-regs 8 f } - T{ ##load-immediate f V int-regs 9 8 f } - T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } - T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f } - T{ ##replace f V int-regs 7 D 0 f } + T{ ##peek f 4 D 0 f } + T{ ##allot f 7 24 array 8 f } + T{ ##load-immediate f 9 8 f } + T{ ##set-slot-imm f 9 7 1 3 f } + T{ ##set-slot-imm f 4 7 2 3 f } + T{ ##replace f 7 D 0 f } T{ ##branch } } ] [ { - T{ ##peek f V int-regs 4 D 0 } - T{ ##allot f V int-regs 7 24 array V int-regs 8 } - T{ ##load-immediate f V int-regs 9 8 } - T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } - T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } - T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 } - T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } - T{ ##replace f V int-regs 7 D 0 } + T{ ##peek f 4 D 0 } + T{ ##allot f 7 24 array 8 } + T{ ##load-immediate f 9 8 } + T{ ##set-slot-imm f 9 7 1 3 } + T{ ##write-barrier f 7 10 11 } + T{ ##set-slot-imm f 4 7 2 3 } + T{ ##write-barrier f 7 12 13 } + T{ ##replace f 7 D 0 } } test-write-barrier ] unit-test [ V{ - T{ ##load-immediate f V int-regs 4 24 } - T{ ##peek f V int-regs 5 D -1 } - T{ ##peek f V int-regs 6 D -2 } - T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } - T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##load-immediate f 4 24 } + T{ ##peek f 5 D -1 } + T{ ##peek f 6 D -2 } + T{ ##set-slot-imm f 5 6 3 2 } + T{ ##write-barrier f 6 7 8 } T{ ##branch } } ] [ { - T{ ##load-immediate f V int-regs 4 24 } - T{ ##peek f V int-regs 5 D -1 } - T{ ##peek f V int-regs 6 D -2 } - T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } - T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##load-immediate f 4 24 } + T{ ##peek f 5 D -1 } + T{ ##peek f 6 D -2 } + T{ ##set-slot-imm f 5 6 3 2 } + T{ ##write-barrier f 6 7 8 } } test-write-barrier ] unit-test [ V{ - T{ ##peek f V int-regs 19 D -3 } - T{ ##peek f V int-regs 22 D -2 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } - T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } - T{ ##peek f V int-regs 28 D -1 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##peek f 19 D -3 } + T{ ##peek f 22 D -2 } + T{ ##set-slot-imm f 22 19 3 2 } + T{ ##write-barrier f 19 24 25 } + T{ ##peek f 28 D -1 } + T{ ##set-slot-imm f 28 19 4 2 } T{ ##branch } } ] [ { - T{ ##peek f V int-regs 19 D -3 } - T{ ##peek f V int-regs 22 D -2 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } - T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } - T{ ##peek f V int-regs 28 D -1 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } - T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 } + T{ ##peek f 19 D -3 } + T{ ##peek f 22 D -2 } + T{ ##set-slot-imm f 22 19 3 2 } + T{ ##write-barrier f 19 24 25 } + T{ ##peek f 28 D -1 } + T{ ##set-slot-imm f 28 19 4 2 } + 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{ ##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 diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 2f32a4ca81..2375075df5 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,7 +1,8 @@ -! 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 ; +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.dataflow-analysis fry combinators.short-circuit ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -30,10 +31,27 @@ M: ##set-slot-imm eliminate-write-barrier M: insn eliminate-write-barrier drop t ; +FORWARD-ANALYSIS: safe + +: has-allocation? ( bb -- ? ) + instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ; + +M: safe-analysis transfer-set + drop [ H{ } assoc-clone-like ] dip + instructions>> over '[ + dup ##write-barrier? [ + src>> _ conjoin + ] [ drop ] if + ] each ; + +M: safe-analysis join-sets + drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ; + : write-barriers-step ( bb -- ) - H{ } clone safe set + dup safe-in H{ } assoc-clone-like safe set H{ } clone mutated set instructions>> [ eliminate-write-barrier ] filter-here ; : eliminate-write-barriers ( cfg -- cfg' ) + dup compute-safe-sets dup [ write-barriers-step ] each-basic-block ; diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 9c3817bad6..225577d0b9 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -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 diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 672ed9ce02..d1a09394cd 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -173,12 +173,12 @@ M: ##div-float generate-insn dst/src1/src2 %div-float ; M: ##integer>float generate-insn dst/src %integer>float ; M: ##float>integer generate-insn dst/src %float>integer ; -M: ##copy generate-insn dst/src %copy ; -M: ##copy-float generate-insn dst/src %copy-float ; -M: ##unbox-float generate-insn dst/src %unbox-float ; -M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ; -M: ##box-float generate-insn dst/src/temp %box-float ; -M: ##box-alien generate-insn dst/src/temp %box-alien ; +M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ; + +M: ##unbox-float generate-insn dst/src %unbox-float ; +M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ; +M: ##box-float generate-insn dst/src/temp %box-float ; +M: ##box-alien generate-insn dst/src/temp %box-alien ; M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ; M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ; @@ -226,31 +226,37 @@ M: ##write-barrier generate-insn GENERIC# save-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot save-gc-root ( gc-root operand temp -- ) - temp operand n>> %reload-integer + temp operand n>> int-rep %reload gc-root temp %save-gc-root ; M: object save-gc-root drop %save-gc-root ; : save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ; +: save-data-regs ( data-regs -- ) [ first3 %spill ] each ; + GENERIC# load-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot load-gc-root ( gc-root operand temp -- ) gc-root temp %load-gc-root - temp operand n>> %spill-integer ; + temp operand n>> int-rep %spill ; M: object load-gc-root drop %load-gc-root ; : load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ; +: load-data-regs ( data-regs -- ) [ first3 %reload ] each ; + M: _gc generate-insn "no-gc" define-label { [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ] [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ] - [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ] - [ gc-root-count>> %call-gc ] - [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ] + [ data-values>> save-data-regs ] + [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ] + [ tagged-values>> length %call-gc ] + [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ] + [ data-values>> load-data-regs ] } cleave "no-gc" resolve-label ; @@ -261,54 +267,45 @@ M: ##alien-global generate-insn %alien-global ; ! ##alien-invoke -GENERIC: reg-class-variable ( register-class -- symbol ) +GENERIC: next-fastcall-param ( reg-class -- ) -M: reg-class reg-class-variable ; +: ?dummy-stack-params ( rep -- ) + dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; -M: float-regs reg-class-variable drop float-regs ; +: ?dummy-int-params ( rep -- ) + dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; -GENERIC: inc-reg-class ( register-class -- ) - -: ?dummy-stack-params ( reg-class -- ) - dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ; - -: ?dummy-int-params ( reg-class -- ) - dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ; - -: ?dummy-fp-params ( reg-class -- ) +: ?dummy-fp-params ( rep -- ) drop dummy-fp-params? [ float-regs inc ] when ; -M: int-regs inc-reg-class - [ reg-class-variable inc ] - [ ?dummy-stack-params ] - [ ?dummy-fp-params ] - tri ; +M: int-rep next-fastcall-param + int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; -M: float-regs inc-reg-class - [ reg-class-variable inc ] - [ ?dummy-stack-params ] - [ ?dummy-int-params ] - tri ; +M: single-float-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; -GENERIC: reg-class-full? ( class -- ? ) +M: double-float-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +GENERIC: reg-class-full? ( reg-class -- ? ) M: stack-params reg-class-full? drop t ; -M: object reg-class-full? - [ reg-class-variable get ] [ param-regs length ] bi >= ; +M: reg-class reg-class-full? + [ get ] [ param-regs length ] bi >= ; -: spill-param ( reg-class -- n reg-class ) +: alloc-stack-param ( rep -- n reg-class rep ) stack-params get - [ reg-size cell align stack-params +@ ] dip - stack-params ; + [ rep-size cell align stack-params +@ ] dip + stack-params dup ; -: fastcall-param ( reg-class -- n reg-class ) - [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ; +: alloc-fastcall-param ( rep -- n reg-class rep ) + [ reg-class-of [ get ] [ inc ] [ ] tri ] keep ; -: alloc-parameter ( parameter -- reg reg-class ) - c-type-reg-class dup reg-class-full? - [ spill-param ] [ fastcall-param ] if - [ param-reg ] keep ; +: alloc-parameter ( parameter -- reg rep ) + c-type-rep dup reg-class-of reg-class-full? + [ alloc-stack-param ] [ alloc-fastcall-param ] if + [ param-reg ] dip ; : (flatten-int-type) ( size -- seq ) cell /i "void*" c-type ; @@ -340,12 +337,12 @@ M: long-long-type flatten-value-type ( type -- types ) : reverse-each-parameter ( parameters quot -- ) [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline -: reset-freg-counts ( -- ) +: reset-fastcall-counts ( -- ) { int-regs float-regs stack-params } [ 0 swap set ] each ; : with-param-regs ( quot -- ) #! In quot you can call alloc-parameter - [ reset-freg-counts call ] with-scope ; inline + [ reset-fastcall-counts call ] with-scope ; inline : move-parameters ( node word -- ) #! Moves values from C stack to registers (if word is @@ -431,6 +428,7 @@ M: ##alien-indirect generate-insn alien-parameters [ box-parameter ] each-parameter ; : registers>objects ( node -- ) + ! Generate code for boxing input parameters in a callback. [ dup \ %save-param-reg move-parameters "nest_stacks" f %alien-invoke @@ -528,21 +526,9 @@ M: _compare-float-branch generate-insn >binary-branch< %compare-float-branch ; M: _spill generate-insn - [ src>> ] [ n>> ] [ class>> ] tri { - { int-regs [ %spill-integer ] } - { double-float-regs [ %spill-float ] } - } case ; + [ src>> ] [ n>> ] [ rep>> ] tri %spill ; M: _reload generate-insn - [ dst>> ] [ n>> ] [ class>> ] tri { - { int-regs [ %reload-integer ] } - { double-float-regs [ %reload-float ] } - } case ; + [ dst>> ] [ n>> ] [ rep>> ] tri %reload ; -M: _copy generate-insn - [ dst>> ] [ src>> ] [ class>> ] tri { - { int-regs [ %copy ] } - { double-float-regs [ %copy-float ] } - } case ; - -M: _spill-counts generate-insn drop ; +M: _spill-area-size generate-insn drop ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 6d0f6f3ace..3b8d996f34 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -12,6 +12,7 @@ compiler.errors compiler.units compiler.utilities compiler.tree.builder compiler.tree.optimizer +compiler.cfg compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.mr @@ -152,8 +153,7 @@ t compile-dependencies? set-global : backend ( tree word -- ) build-cfg [ - optimize-cfg - build-mr + [ optimize-cfg build-mr ] with-cfg generate save-asm ] each ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 91215baf19..e3c5dee917 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -395,7 +395,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-9 ( -- callback ) "int" { "int" "int" "int" } "cdecl" [ - + + 1+ + + + 1 + ] alien-callback ; FUNCTION: void ffi_test_36_point_5 ( ) ; @@ -599,4 +599,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ 123 ] [ "bool-field-test" 123 over set-bool-field-test-parents ffi_test_48 -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor index a9fd313d64..f90897bc9b 100644 --- a/basis/compiler/tests/call-effect.factor +++ b/basis/compiler/tests/call-effect.factor @@ -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 ) ; @@ -11,4 +11,4 @@ USING: tools.test combinators generic.single sequences kernel ; [ ] [ [ ] call-test ] unit-test [ ] [ f [ drop ] curry call-test ] unit-test [ ] [ [ ] [ ] compose call-test ] unit-test -[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with \ No newline at end of file +[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index ffd7295501..5f06fc8d2a 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -392,4 +392,13 @@ cell 4 = [ [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test - [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test \ No newline at end of file + [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test + +! Global stack analysis dataflow equations are wrong +: some-word ( a -- b ) 2 + ; +: global-dcn-bug-1 ( a b -- c d ) + dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if + dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ; + +[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test +[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 7074b73845..138437543e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -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 diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor index 6b0ef2d439..30392f1598 100644 --- a/basis/compiler/tests/generic.factor +++ b/basis/compiler/tests/generic.factor @@ -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 ; @@ -8,4 +8,4 @@ M: object bad ; [ 0 bad ] must-fail [ "" bad ] must-fail -[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index f1ebeded7b..ececac3037 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -12,15 +12,16 @@ IN: compiler.tests.low-level-ir [ associate >alist modify-code-heap ] keep ; : compile-test-cfg ( -- word ) - cfg new - 0 get >>entry + cfg new 0 get >>entry + dup cfg set + dup fake-representations representations get >>reps compile-cfg ; : compile-test-bb ( insns -- result ) V{ T{ ##prologue } T{ ##branch } } 0 test-bb V{ T{ ##inc-d f 1 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f 0 D 0 } T{ ##branch } } [ clone ] map append 1 test-bb V{ @@ -35,13 +36,13 @@ IN: compiler.tests.low-level-ir ! loading immediates [ f ] [ V{ - T{ ##load-immediate f V int-regs 0 5 } + T{ ##load-immediate f 0 5 } } compile-test-bb ] unit-test [ "hello" ] [ V{ - T{ ##load-reference f V int-regs 0 "hello" } + T{ ##load-reference f 0 "hello" } } compile-test-bb ] unit-test @@ -49,72 +50,72 @@ IN: compiler.tests.low-level-ir ! one of the sources [ t ] [ V{ - T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } - T{ ##load-reference f V int-regs 0 { t f t } } - T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + T{ ##load-immediate f 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f 0 { t f t } } + T{ ##slot f 0 0 1 $[ array tag-number ] 2 } } compile-test-bb ] unit-test [ t ] [ V{ - T{ ##load-reference f V int-regs 0 { t f t } } - T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 } + T{ ##load-reference f 0 { t f t } } + T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 } } compile-test-bb ] unit-test [ t ] [ V{ - T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } - T{ ##load-reference f V int-regs 0 { t f t } } - T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + T{ ##load-immediate f 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f 0 { t f t } } + T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 } } compile-test-bb dup first eq? ] unit-test [ t ] [ V{ - T{ ##load-reference f V int-regs 0 { t f t } } - T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] } + T{ ##load-reference f 0 { t f t } } + T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] } } compile-test-bb dup first eq? ] unit-test [ 8 ] [ V{ - T{ ##load-immediate f V int-regs 0 4 } - T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 } + T{ ##load-immediate f 0 4 } + T{ ##shl f 0 0 0 } } compile-test-bb ] unit-test [ 4 ] [ V{ - T{ ##load-immediate f V int-regs 0 4 } - T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + T{ ##load-immediate f 0 4 } + T{ ##shl-imm f 0 0 3 } } compile-test-bb ] unit-test [ 31 ] [ V{ - T{ ##load-reference f V int-regs 1 B{ 31 67 52 } } - T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 } - T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 } - T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + T{ ##load-reference f 1 B{ 31 67 52 } } + T{ ##unbox-any-c-ptr f 0 1 2 } + T{ ##alien-unsigned-1 f 0 0 } + T{ ##shl-imm f 0 0 3 } } compile-test-bb ] unit-test [ CHAR: l ] [ V{ - T{ ##load-reference f V int-regs 0 "hello world" } - T{ ##load-immediate f V int-regs 1 3 } - T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 } - T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + T{ ##load-reference f 0 "hello world" } + T{ ##load-immediate f 1 3 } + T{ ##string-nth f 0 0 1 2 } + T{ ##shl-imm f 0 0 3 } } compile-test-bb ] unit-test [ 1 ] [ V{ - T{ ##load-immediate f V int-regs 0 16 } - T{ ##add-imm f V int-regs 0 V int-regs 0 -8 } + T{ ##load-immediate f 0 16 } + T{ ##add-imm f 0 0 -8 } } compile-test-bb ] unit-test @@ -125,15 +126,15 @@ USE: multiline [ 100 ] [ V{ - T{ ##load-immediate f V int-regs 0 100 } - T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f 0 100 } + T{ ##integer>bignum f 0 0 1 } } compile-test-bb ] unit-test [ 1 ] [ V{ - T{ ##load-reference f V int-regs 0 ALIEN: 8 } - T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 } + T{ ##load-reference f 0 ALIEN: 8 } + T{ ##unbox-any-c-ptr f 0 0 1 } } compile-test-bb ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 72618db456..9cd6cfaef2 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * ) ! regression : branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive + t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive : branch-fold-regression-1 ( -- m ) 10 branch-fold-regression-0 ; @@ -348,12 +348,12 @@ TUPLE: some-tuple x ; [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test -[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ; @@ -382,7 +382,7 @@ DEFER: loop-bbb ! Type inference issue [ 4 3 ] [ 1 >bignum 2 >bignum - [ { bignum integer } declare [ shift ] keep 1+ ] compile-call + [ { bignum integer } declare [ shift ] keep 1 + ] compile-call ] unit-test : broken-declaration ( -- ) \ + declare ; @@ -391,6 +391,17 @@ DEFER: loop-bbb [ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test +! Interval inference issue +[ f ] [ + 10 70 + [ + dup 70 >= + [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ] + [ 2drop 70 ] if + 70 >= + ] compile-call +] unit-test + ! Modular arithmetic bug : modular-arithmetic-bug ( a -- b ) >integer 256 mod ; @@ -411,4 +422,4 @@ M: object bad-dispatch-position-test* ; \ bad-dispatch-position-test forget \ bad-dispatch-position-test* forget ] with-compilation-unit -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 7929d9e6f6..cae57e5bd9 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; +IN: compiler.tests.peg-regression-2 GENERIC: ( times -- term' ) M: string ; diff --git a/basis/compiler/tests/pic-problem-1.factor b/basis/compiler/tests/pic-problem-1.factor index 4adf0b36b9..4da83f53e4 100644 --- a/basis/compiler/tests/pic-problem-1.factor +++ b/basis/compiler/tests/pic-problem-1.factor @@ -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 ; @@ -11,4 +11,4 @@ INSTANCE: x sequence CONSTANT: blah T{ x } -[ T{ x } ] [ blah ] unit-test \ No newline at end of file +[ T{ x } ] [ blah ] unit-test diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index 3d7a05a74b..4de6d952c8 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -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 ; diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor index 33aa080bac..54066c690d 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -11,7 +11,7 @@ DEFER: word-1 : word-3 ( a -- b ) 1 + ; -: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ; +: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ; [ 1 1 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index 3bef30f9f1..ac879a7c75 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -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 diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor index 4ed3e36f4d..5a1c33ad27 100644 --- a/basis/compiler/tests/redefine17.factor +++ b/basis/compiler/tests/redefine17.factor @@ -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 >> diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 9112a1e1af..b6a46fc0df 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -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 diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 0a5eb84579..38842696d7 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,7 +1,7 @@ -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 ) diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2320f64af6..cc74e5a783 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -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 diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index 62c7c31bc2..3bbfca876b 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.reload USE: vocabs.loader +IN: compiler.tests.reload ! "parser" reload ! "sequences" reload diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index 1cb11571ef..a160272b21 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -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 diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index fc249d99db..3d6301249f 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; +IN: compiler.tests.tuples TUPLE: color red green blue ; diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index b7ee51834b..83093470c9 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -9,5 +9,5 @@ HELP: build-tree { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; HELP: build-sub-tree -{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } } +{ $values { "in-d" "a sequence of values" } { "out-d" "a sequence of values" } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } } { $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index f3a2b99db6..8359334550 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -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 diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 00325f5a72..e4523deb9f 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -49,19 +49,18 @@ PRIVATE> : build-tree ( word/quot -- nodes ) [ f ] dip build-tree-with ; -:: build-sub-tree ( #call word/quot -- nodes/f ) +:: build-sub-tree ( in-d out-d word/quot -- nodes/f ) #! We don't want methods on mixins to have a declaration for that mixin. #! This slows down compiler.tree.propagation.inlining since then every #! inlined usage of a method has an inline-dependency on the mixin, and #! not the more specific type at the call site. f specialize-method? [ [ - #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + in-d word/quot build-tree-with unclip-last in-d>> :> in-d' { { [ dup not ] [ ] } - { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } - [ in-d #call out-d>> #copy suffix ] + { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] } + [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ] } cond ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover - ] with-variable ; - + ] with-variable ; \ No newline at end of file diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor deleted file mode 100644 index d9591e7be2..0000000000 --- a/basis/compiler/tree/checker/checker-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: compiler.tree.checker.tests -USING: compiler.tree.checker tools.test ; - - diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index e25f152aef..0b3b46fe33 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -5,6 +5,7 @@ arrays combinators continuations columns math vectors grouping stack-checker.branches compiler.tree compiler.tree.def-use +compiler.tree.recursive compiler.tree.combinators ; IN: compiler.tree.checker diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 228a4e3efb..bc8a7b0765 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -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 @@ -88,7 +88,7 @@ M: object xyz ; 2over dup xyz drop >= [ 3drop ] [ - [ swap [ call 1+ ] dip ] keep (i-repeat) + [ swap [ call 1 + ] dip ] keep (i-repeat) ] if ; inline recursive : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline @@ -543,4 +543,4 @@ cell-bits 32 = [ [ 12 swap nth ] keep 14 ndrop ] cleaned-up-tree nodes>quot -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 1b0343faa9..1cd9589065 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -20,7 +20,7 @@ IN: compiler.tree.cleanup GENERIC: delete-node ( node -- ) M: #call-recursive delete-node - dup label>> [ [ eq? not ] with filter ] change-calls drop ; + dup label>> calls>> [ node>> eq? not ] with filter-here ; M: #return-recursive delete-node label>> f >>return drop ; @@ -89,8 +89,6 @@ M: #call cleanup* [ ] } cond ; -M: #declare cleanup* drop f ; - : delete-unreachable-branches ( #branch -- ) dup live-branches>> '[ _ diff --git a/basis/compiler/tree/combinators/combinators-tests.factor b/basis/compiler/tree/combinators/combinators-tests.factor index d012b5f658..305ba5b2b5 100644 --- a/basis/compiler/tree/combinators/combinators-tests.factor +++ b/basis/compiler/tree/combinators/combinators-tests.factor @@ -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 diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index fd1b2d5adb..f09593824e 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -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 ; diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 71830d07e7..b0ab864c80 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -3,6 +3,7 @@ USING: accessors arrays assocs sequences kernel locals fry combinators stack-checker.backend compiler.tree +compiler.tree.recursive compiler.tree.dead-code.branches compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ; diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9bacd51be1..3cdbbf5944 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -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. -[ [ print ] each ] optimizer-report. \ No newline at end of file +[ [ print ] each ] optimizer-report. diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index d6906d6348..a99e547b31 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -16,6 +16,7 @@ compiler.tree.builder compiler.tree.optimizer compiler.tree.combinators compiler.tree.checker +compiler.tree.identities compiler.tree.dead-code compiler.tree.modular-arithmetic ; FROM: fry => _ ; @@ -153,7 +154,7 @@ SYMBOL: node-count H{ } clone intrinsics-called set 0 swap [ - [ 1+ ] dip + [ 1 + ] dip dup #call? [ word>> { { [ dup "intrinsic" word-prop ] [ intrinsics-called ] } @@ -208,6 +209,7 @@ SYMBOL: node-count normalize propagate cleanup + apply-identities compute-def-use remove-dead-code compute-def-use diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index fa504919a3..21e79eb6c4 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -43,7 +43,7 @@ GENERIC: node-uses-values ( node -- values ) M: #introduce node-uses-values drop f ; M: #push node-uses-values drop f ; M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ; -M: #declare node-uses-values declaration>> keys ; +M: #declare node-uses-values drop f ; M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ; M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ; M: #alien-callback node-uses-values drop f ; diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor index 5d34eaad15..5291c5e81f 100644 --- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,9 +1,16 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces sequences kernel math combinators sets disjoint-sets fry stack-checker.values ; IN: compiler.tree.escape-analysis.allocations +! A map from values to classes. Only for #introduce outputs +SYMBOL: value-classes + +: value-class ( value -- class ) value-classes get at ; + +: set-value-class ( class value -- ) value-classes get set-at ; + ! A map from values to one of the following: ! - f -- initial status, assigned to values we have not seen yet; ! may potentially become an allocation later diff --git a/basis/compiler/tree/escape-analysis/check/check-tests.factor b/basis/compiler/tree/escape-analysis/check/check-tests.factor new file mode 100644 index 0000000000..bd91dd53e8 --- /dev/null +++ b/basis/compiler/tree/escape-analysis/check/check-tests.factor @@ -0,0 +1,27 @@ +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? ; + +[ t ] [ + [ { complex } declare [ real>> ] [ imaginary>> ] bi ] + test-checker +] unit-test + +[ t ] [ + [ complex boa [ real>> ] [ imaginary>> ] bi ] + test-checker +] unit-test + +[ t ] [ + [ [ complex boa [ real>> ] [ imaginary>> ] bi ] when ] + test-checker +] unit-test + +[ f ] [ + [ swap 1 2 ? ] + test-checker +] unit-test diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor index ed253ad89b..4679dfe342 100644 --- a/basis/compiler/tree/escape-analysis/check/check.factor +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -1,22 +1,32 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.tuple math math.private accessors -combinators kernel compiler.tree compiler.tree.combinators -compiler.tree.propagation.info ; +USING: classes classes.tuple math math.private accessors sequences +combinators.short-circuit kernel compiler.tree +compiler.tree.combinators compiler.tree.propagation.info ; IN: compiler.tree.escape-analysis.check GENERIC: run-escape-analysis* ( node -- ? ) -M: #push run-escape-analysis* - literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ; - -M: #call run-escape-analysis* +: unbox-inputs? ( nodes -- ? ) { - { [ dup immutable-tuple-boa? ] [ t ] } - [ f ] - } cond nip ; - -M: node run-escape-analysis* drop f ; + [ length 2 >= ] + [ first #introduce? ] + [ second #declare? ] + } 1&& ; : run-escape-analysis? ( nodes -- ? ) - [ run-escape-analysis* ] contains-node? ; + { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ; + +M: #push run-escape-analysis* + literal>> class immutable-tuple-class? ; + +M: #call run-escape-analysis* + immutable-tuple-boa? ; + +M: #recursive run-escape-analysis* + child>> run-escape-analysis? ; + +M: #branch run-escape-analysis* + children>> [ run-escape-analysis? ] any? ; + +M: node run-escape-analysis* drop f ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 4fb01608f0..debb66b8d4 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -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 @@ -9,12 +8,13 @@ quotations.private prettyprint classes.tuple.private classes classes.tuple namespaces compiler.tree.propagation.info stack-checker.errors compiler.tree.checker -kernel.private ; +kernel.private vectors ; +IN: compiler.tree.escape-analysis.tests GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) - out-d>> first escaping-allocation? [ 1+ ] unless ; + out-d>> first escaping-allocation? [ 1 + ] unless ; M: #call count-unboxed-allocations* dup immutable-tuple-boa? @@ -24,6 +24,9 @@ M: #push count-unboxed-allocations* dup literal>> class immutable-tuple-class? [ (count-unboxed-allocations) ] [ drop ] if ; +M: #introduce count-unboxed-allocations* + out-d>> [ escaping-allocation? [ 1 + ] unless ] each ; + M: node count-unboxed-allocations* drop ; : count-unboxed-allocations ( quot -- sizes ) @@ -209,10 +212,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup tuple-fib swap - i>> 1- + i>> 1 - tuple-fib swap i>> swap i>> + ] if ; inline recursive @@ -222,7 +225,7 @@ C: ro-box [ 3 ] [ [ tuple-fib ] count-unboxed-allocations ] unit-test : tuple-fib' ( m -- n ) - dup 1 <= [ 1- tuple-fib' i>> ] when ; inline recursive + dup 1 <= [ 1 - tuple-fib' i>> ] when ; inline recursive [ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test @@ -230,10 +233,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup bad-tuple-fib-1 swap - i>> 1- + i>> 1 - bad-tuple-fib-1 dup . swap i>> swap i>> + ] if ; inline recursive @@ -245,10 +248,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup bad-tuple-fib-2 swap - i>> 1- + i>> 1 - bad-tuple-fib-2 swap i>> swap i>> + ] if ; inline recursive @@ -259,9 +262,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup tuple-fib-2 + 1 - dup tuple-fib-2 swap - 1- tuple-fib-2 + 1 - tuple-fib-2 swap i>> swap i>> + ] if ; inline recursive @@ -271,9 +274,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup tuple-fib-3 + 1 - dup tuple-fib-3 swap - 1- tuple-fib-3 dup . + 1 - tuple-fib-3 dup . swap i>> swap i>> + ] if ; inline recursive @@ -283,9 +286,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup bad-tuple-fib-3 + 1 - dup bad-tuple-fib-3 swap - 1- bad-tuple-fib-3 + 1 - bad-tuple-fib-3 2drop f ] if ; inline recursive @@ -328,3 +331,17 @@ C: ro-box TUPLE: empty-tuple ; [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test + +! New feature! + +[ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test + +[ 1 ] [ + [ { complex } declare [ real>> ] [ imaginary>> ] bi ] + count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ { vector } declare length>> ] + count-unboxed-allocations +] unit-test diff --git a/basis/compiler/tree/escape-analysis/escape-analysis.factor b/basis/compiler/tree/escape-analysis/escape-analysis.factor index 82e41d7b49..dcad55742b 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis.factor @@ -15,5 +15,6 @@ IN: compiler.tree.escape-analysis init-escaping-values H{ } clone allocations set H{ } clone slot-accesses set + H{ } clone value-classes set dup (escape-analysis) compute-escaping-allocations ; diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor index 3fdde22bd8..3451750a34 100644 --- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor +++ b/basis/compiler/tree/escape-analysis/nodes/nodes.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences +USING: kernel sequences fry math namespaces compiler.tree compiler.tree.def-use compiler.tree.escape-analysis.allocations ; @@ -8,9 +8,14 @@ IN: compiler.tree.escape-analysis.nodes GENERIC: escape-analysis* ( node -- ) +SYMBOL: next-node + +: each-with-next ( seq quot: ( elt -- ) -- ) + dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline + : (escape-analysis) ( node -- ) [ [ node-defs-values introduce-values ] [ escape-analysis* ] bi - ] each ; + ] each-with-next ; diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor index 033d5b01cc..c26f3ddefc 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -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 set diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor index 5aece23d17..ad6572a35c 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor @@ -3,6 +3,7 @@ USING: kernel sequences math combinators accessors namespaces fry disjoint-sets compiler.tree +compiler.tree.recursive compiler.tree.combinators compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.branches @@ -67,5 +68,5 @@ M: #return-recursive escape-analysis* ( #return-recursive -- ) [ call-next-method ] [ [ in-d>> ] [ label>> calls>> ] bi - [ out-d>> escaping-values get '[ _ equate ] 2each ] with each + [ node>> out-d>> escaping-values get '[ _ equate ] 2each ] with each ] bi ; diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index c0b3982c0e..c053b15f29 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -1,20 +1,36 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences classes.tuple classes.tuple.private arrays math math.private slots.private combinators deques search-deques namespaces fry classes -classes.algebra stack-checker.state +classes.algebra assocs stack-checker.state compiler.tree compiler.tree.propagation.info compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.simple +M: #declare escape-analysis* drop ; + M: #terminate escape-analysis* drop ; M: #renaming escape-analysis* inputs/outputs copy-values ; -M: #introduce escape-analysis* out-d>> unknown-allocations ; +: declared-class ( value -- class/f ) + next-node get dup #declare? [ declaration>> at ] [ 2drop f ] if ; + +: record-param-allocation ( value class -- ) + dup immutable-tuple-class? [ + [ swap set-value-class ] [ + all-slots [ + [ dup ] [ class>> ] bi* + record-param-allocation + ] map swap record-allocation + ] 2bi + ] [ drop unknown-allocation ] if ; + +M: #introduce escape-analysis* + out-d>> [ dup declared-class record-param-allocation ] each ; DEFER: record-literal-allocation @@ -24,7 +40,6 @@ DEFER: record-literal-allocation : object-slots ( object -- slots/f ) { { [ dup class immutable-tuple-class? ] [ tuple-slots ] } - { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] } [ drop f ] } cond ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 13555d45f7..7d40bf3fc1 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -1,12 +1,12 @@ ! 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 strings sbufs +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 ; +IN: compiler.tree.modular-arithmetic.tests : test-modular-arithmetic ( quot -- quot' ) cleaned-up-tree nodes>quot ; @@ -171,3 +171,8 @@ cell { [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test [ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test + +[ t ] [ + [ 0 10 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ] + { >fixnum } inlined? +] unit-test diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 3b4574effe..19669c2239 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -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 diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor deleted file mode 100644 index 5d05947b8a..0000000000 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: compiler.tree.optimizer tools.test ; -IN: compiler.tree.optimizer.tests - - diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index ec2a4b1ece..a667ea727f 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -35,7 +35,7 @@ M: +unknown+ curry-effect ; M: effect curry-effect [ in>> length ] [ out>> length ] [ terminated?>> ] tri - pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if + pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if effect boa ; M: curry cached-effect diff --git a/basis/compiler/tree/propagation/copy/copy-tests.factor b/basis/compiler/tree/propagation/copy/copy-tests.factor index a99c2a2447..b546e56e4b 100644 --- a/basis/compiler/tree/propagation/copy/copy-tests.factor +++ b/basis/compiler/tree/propagation/copy/copy-tests.factor @@ -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 diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 72c08dbf1c..826131ab61 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -74,3 +74,13 @@ TUPLE: test-tuple { x read-only } ; [ t ] [ null-info 3 value-info<= ] unit-test + +[ t t ] [ + f + fixnum 0 40 [a,b] + value-info-union + \ f class-not + value-info-intersect + [ class>> fixnum class= ] + [ interval>> 0 40 [a,b] = ] bi +] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index a2dec12279..0a04b48160 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! 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 words combinators byte-arrays strings -arrays layouts cpu.architecture compiler.tree.propagation.copy ; +classes.tuple.private kernel accessors math math.intervals namespaces +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 : false-class? ( class -- ? ) \ f class<= ; @@ -36,10 +37,6 @@ CONSTANT: null-info T{ value-info f null empty-interval } CONSTANT: object-info T{ value-info f object full-interval } -: class-interval ( class -- interval ) - dup real class<= - [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ; - : interval>literal ( class interval -- literal literal? ) #! If interval has zero length and the class is sufficiently #! precise, we can turn it into a literal @@ -69,7 +66,7 @@ DEFER: UNION: fixed-length array byte-array string ; : init-literal-info ( info -- info ) - [-inf,inf] >>interval + empty-interval >>interval dup literal>> class >>class dup literal>> { { [ dup real? ] [ [a,a] >>interval ] } @@ -78,16 +75,54 @@ UNION: fixed-length array byte-array string ; [ drop ] } cond ; inline +: empty-set? ( info -- ? ) + { + [ class>> null-class? ] + [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ] + } 1|| ; + +: min-value ( class -- n ) + { + { fixnum [ most-negative-fixnum ] } + { array-capacity [ 0 ] } + [ drop -1/0. ] + } case ; + +: max-value ( class -- n ) + { + { fixnum [ most-positive-fixnum ] } + { array-capacity [ max-array-capacity ] } + [ drop 1/0. ] + } case ; + +: class-interval ( class -- i ) + { + { fixnum [ fixnum-interval ] } + { array-capacity [ array-capacity-interval ] } + [ drop full-interval ] + } case ; + +: wrap-interval ( interval class -- interval' ) + { + { [ over empty-interval eq? ] [ drop ] } + { [ over full-interval eq? ] [ nip class-interval ] } + { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] } + [ drop ] + } cond ; + +: init-interval ( info -- info ) + dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval + dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline + : init-value-info ( info -- info ) dup literal?>> [ init-literal-info ] [ - dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ + dup empty-set? [ null >>class empty-interval >>interval ] [ - [ [-inf,inf] or ] change-interval - dup class>> integer class<= [ [ integral-closure ] change-interval ] when + init-interval dup [ class>> ] [ interval>> ] bi interval>literal [ >>literal ] [ >>literal? ] bi* ] if @@ -100,8 +135,7 @@ UNION: fixed-length array byte-array string ; init-value-info ; foldable : ( class -- info ) - dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or - ; foldable + f ; foldable : ( interval -- info ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 4d54dc5e39..8f8c0773aa 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -19,7 +19,7 @@ IN: compiler.tree.propagation.inlining SYMBOL: node-count : count-nodes ( nodes -- n ) - 0 swap [ drop 1+ ] each-node ; + 0 swap [ drop 1 + ] each-node ; : compute-node-count ( nodes -- ) count-nodes node-count set ; @@ -31,8 +31,11 @@ SYMBOL: inlining-count : splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; +: open-code-#call ( #call word/quot -- nodes/f ) + [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ; + : splicing-body ( #call quot/word -- nodes/f ) - build-sub-tree dup [ analyze-recursive normalize ] when ; + open-code-#call dup [ analyze-recursive normalize ] when ; ! Dispatch elimination : undo-inlining ( #call -- ? ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index f5ea64bc0a..7c684f5b7f 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -18,14 +18,6 @@ compiler.tree.propagation.call-effect compiler.tree.propagation.transforms ; IN: compiler.tree.propagation.known-words -\ fixnum -most-negative-fixnum most-positive-fixnum [a,b] -"interval" set-word-prop - -\ array-capacity -0 max-array-capacity [a,b] -"interval" set-word-prop - { + - * / } [ { number number } "input-classes" set-word-prop ] each @@ -53,8 +45,8 @@ most-negative-fixnum most-positive-fixnum [a,b] { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; -: fits? ( interval class -- ? ) - "interval" word-prop interval-subset? ; +: fits-in-fixnum? ( interval -- ? ) + fixnum-interval interval-subset? ; : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ @@ -66,7 +58,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ [ interval>> ] bi@ ] dip call ; inline : won't-overflow? ( class interval -- ? ) - [ fixnum class<= ] [ fixnum fits? ] bi* and ; + [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ; : may-overflow ( class interval -- class' interval' ) over null-class? [ @@ -173,7 +165,8 @@ generic-comparison-ops [ [ object-info ] [ f ] if ; : info-intervals-intersect? ( info1 info2 -- ? ) - [ interval>> ] bi@ intervals-intersect? ; + 2dup [ class>> real class<= ] both? + [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ; { number= bignum= float= } [ [ @@ -218,14 +211,7 @@ generic-comparison-ops [ { >integer integer } } [ - '[ - _ - [ nip ] [ - [ interval>> ] [ class-interval ] bi* - interval-intersect - ] 2bi - - ] "outputs" set-word-prop + '[ _ swap interval>> ] "outputs" set-word-prop ] assoc-each { numerator denominator } @@ -254,14 +240,14 @@ generic-comparison-ops [ dup name>> { { [ "alien-signed-" ?head ] - [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] + [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ] } { [ "alien-unsigned-" ?head ] - [ string>number 8 * 2^ 1- 0 swap [a,b] ] + [ string>number 8 * 2^ 1 - 0 swap [a,b] ] } } cond - [ fixnum fits? fixnum integer ? ] keep + [ fits-in-fixnum? fixnum integer ? ] keep '[ 2drop _ ] "outputs" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 8ec98ccc66..eb9591c40c 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -149,6 +149,14 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ t } ] [ [ 40 mod 40 < ] final-literals ] unit-test + +[ V{ f } ] [ [ 40 mod 0 >= ] final-literals ] unit-test + +[ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test + +[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test + [ V{ string } ] [ [ dup string? not [ "Oops" throw ] [ ] if ] final-classes ] unit-test @@ -270,11 +278,11 @@ IN: compiler.tree.propagation.tests ] unit-test [ V{ fixnum } ] [ - [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes + [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes ] unit-test [ V{ -1 } ] [ - [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals + [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals ] unit-test [ V{ 2 } ] [ @@ -464,7 +472,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test : recursive-test-4 ( i n -- ) - 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive + 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test @@ -479,7 +487,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test : recursive-test-7 ( a -- b ) - dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive + dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive [ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test @@ -632,8 +640,12 @@ MIXIN: empty-mixin [ { integer } declare 127 bitand ] final-info first interval>> ] unit-test +[ V{ t } ] [ + [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals +] unit-test + [ V{ bignum } ] [ - [ { bignum } declare dup 1- bitxor ] final-classes + [ { bignum } declare dup 1 - bitxor ] final-classes ] unit-test [ V{ bignum integer } ] [ @@ -673,7 +685,7 @@ MIXIN: empty-mixin TUPLE: littledan-1 { a read-only } ; -: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive +: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive : littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline @@ -690,7 +702,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ ] [ [ littledan-2-test ] final-classes drop ] unit-test : (littledan-3-test) ( x -- ) - length 1+ f (littledan-3-test) ; inline recursive + length 1 + f (littledan-3-test) ; inline recursive : littledan-3-test ( -- ) 0 f (littledan-3-test) ; inline @@ -699,7 +711,21 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test -[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test +[ V{ 1 } ] [ [ { } length 1 + f length ] final-literals ] unit-test + +! generalize-counter is not tight enough +[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test + +[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test + +! Coercions need to update intervals +[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test + +[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test + +[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test + +[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor index cf72a2a135..974bb584eb 100644 --- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor +++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor @@ -1,19 +1,51 @@ -IN: compiler.tree.propagation.recursive.tests USING: tools.test compiler.tree.propagation.recursive -math.intervals kernel ; +math.intervals kernel math literals layouts ; +IN: compiler.tree.propagation.recursive.tests [ T{ interval f { 0 t } { 1/0. t } } ] [ T{ interval f { 1 t } { 1 t } } - T{ interval f { 0 t } { 0 t } } generalize-counter-interval + T{ interval f { 0 t } { 0 t } } + integer generalize-counter-interval +] unit-test + +[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [ + T{ interval f { 1 t } { 1 t } } + T{ interval f { 0 t } { 0 t } } + fixnum generalize-counter-interval ] unit-test [ T{ interval f { -1/0. t } { 10 t } } ] [ T{ interval f { -1 t } { -1 t } } - T{ interval f { 10 t } { 10 t } } generalize-counter-interval + T{ interval f { 10 t } { 10 t } } + integer generalize-counter-interval +] unit-test + +[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [ + T{ interval f { -1 t } { -1 t } } + T{ interval f { 10 t } { 10 t } } + fixnum generalize-counter-interval ] unit-test [ t ] [ T{ interval f { 1 t } { 268435455 t } } T{ interval f { -268435456 t } { 268435455 t } } tuck - generalize-counter-interval = + integer generalize-counter-interval = +] unit-test + +[ t ] [ + T{ interval f { 1 t } { 268435455 t } } + T{ interval f { -268435456 t } { 268435455 t } } tuck + fixnum generalize-counter-interval = +] unit-test + +[ full-interval ] [ + T{ interval f { -5 t } { 3 t } } + T{ interval f { 2 t } { 11 t } } + integer generalize-counter-interval +] unit-test + +[ $[ fixnum-interval ] ] [ + T{ interval f { -5 t } { 3 t } } + T{ interval f { 2 t } { 11 t } } + fixnum generalize-counter-interval ] unit-test diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index b8d1760a0b..eb4158e756 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -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: kernel sequences accessors arrays fry math.intervals -combinators namespaces +USING: kernel sequences accessors arrays fry math math.intervals +layouts combinators namespaces locals stack-checker.inlining compiler.tree compiler.tree.combinators @@ -21,23 +21,29 @@ IN: compiler.tree.propagation.recursive in-d>> [ value-info ] map ; : recursive-stacks ( #enter-recursive -- stacks initial ) - [ label>> calls>> [ node-input-infos ] map flip ] + [ label>> calls>> [ node>> node-input-infos ] map flip ] [ latest-input-infos ] bi ; -: generalize-counter-interval ( interval initial-interval -- interval' ) +:: generalize-counter-interval ( interval initial-interval class -- interval' ) { - { [ 2dup interval-subset? ] [ empty-interval ] } - { [ over empty-interval eq? ] [ empty-interval ] } - { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] } - { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] } - [ [-inf,inf] ] - } cond interval-union nip ; + { [ interval initial-interval interval-subset? ] [ initial-interval ] } + { [ interval empty-interval eq? ] [ initial-interval ] } + { + [ interval initial-interval interval>= t eq? ] + [ class max-value [a,a] initial-interval interval-union ] + } + { + [ interval initial-interval interval<= t eq? ] + [ class min-value [a,a] initial-interval interval-union ] + } + [ class class-interval ] + } cond ; : generalize-counter ( info' initial -- info ) 2dup [ not ] either? [ drop ] [ 2dup [ class>> null-class? ] either? [ drop ] [ [ clone ] dip - [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ] + [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ] [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] tri diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 86114772f7..4996729ded 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -63,5 +63,5 @@ UNION: fixed-length-sequence array byte-array string ; { [ over 0 = ] [ 2drop fixnum ] } { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } - [ [ 1- ] [ slots>> ] bi* ?nth ] + [ [ 1 - ] [ slots>> ] bi* ?nth ] } cond [ object-info ] unless* ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 3fd7af0324..d6c107b74b 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -20,7 +20,7 @@ IN: compiler.tree.propagation.transforms : rem-custom-inlining ( #call -- quot/f ) second value-info literal>> dup integer? - [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ; { mod-integer-integer @@ -162,7 +162,7 @@ CONSTANT: lookup-table-at-max 256 } 1&& ; : lookup-table-seq ( assoc -- table ) - [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; + [ keys supremum 1 + ] keep '[ _ at ] { } map-as ; : lookup-table-quot ( seq -- newquot ) lookup-table-seq diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 80edae076f..a1cbf15438 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -1,9 +1,10 @@ -IN: compiler.tree.recursive.tests -USING: compiler.tree.recursive tools.test -kernel combinators.short-circuit math sequences accessors +USING: tools.test kernel combinators.short-circuit math sequences accessors compiler.tree compiler.tree.builder -compiler.tree.combinators ; +compiler.tree.combinators +compiler.tree.recursive +compiler.tree.recursive.private ; +IN: compiler.tree.recursive.tests [ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test [ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test @@ -29,7 +30,7 @@ compiler.tree.combinators ; ] curry contains-node? ; : loop-test-1 ( a -- ) - dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive + dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive [ t ] [ [ loop-test-1 ] build-tree analyze-recursive @@ -52,7 +53,7 @@ compiler.tree.combinators ; ] unit-test : loop-test-2 ( a b -- a' ) - dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive + dup [ 1+ loop-test-2 1 - ] [ drop ] if ; inline recursive [ t ] [ [ loop-test-2 ] build-tree analyze-recursive @@ -67,13 +68,6 @@ compiler.tree.combinators ; \ loop-test-3 label-is-not-loop? ] unit-test -: loop-test-4 ( a -- ) - dup [ - loop-test-4 - ] [ - drop - ] if ; inline recursive - [ f ] [ [ [ [ ] map ] map ] build-tree analyze-recursive [ @@ -145,17 +139,32 @@ DEFER: a' DEFER: a'' -: b'' ( -- ) +: b'' ( a -- b ) a'' ; inline recursive -: a'' ( -- ) - b'' a'' ; inline recursive +: a'' ( a -- b ) + dup [ b'' a'' ] when ; inline recursive [ t ] [ [ a'' ] build-tree analyze-recursive \ a'' label-is-not-loop? ] unit-test +[ t ] [ + [ a'' ] build-tree analyze-recursive + \ b'' label-is-loop? +] unit-test + +[ t ] [ + [ b'' ] build-tree analyze-recursive + \ a'' label-is-loop? +] unit-test + +[ t ] [ + [ b'' ] build-tree analyze-recursive + \ b'' label-is-not-loop? +] unit-test + : loop-in-non-loop ( x quot: ( i -- ) -- ) over 0 > [ [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi @@ -166,3 +175,27 @@ DEFER: a'' build-tree analyze-recursive \ (each-integer) label-is-loop? ] unit-test + +DEFER: a''' + +: b''' ( -- ) + blah [ b''' ] [ a''' b''' ] if ; inline recursive + +: a''' ( -- ) + blah [ b''' ] [ a''' ] if ; inline recursive + +[ t ] [ + [ b''' ] build-tree analyze-recursive + \ a''' label-is-loop? +] unit-test + +DEFER: b4 + +: a4 ( a -- b ) dup [ b4 ] when ; inline recursive + +: b4 ( a -- b ) dup [ a4 reverse ] when ; inline recursive + +[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test +[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test +[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test +[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index 2e40693e69..bc6243e138 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -1,104 +1,133 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs arrays namespaces accessors sequences deques -search-deques dlists compiler.tree compiler.tree.combinators ; +USING: kernel assocs arrays namespaces accessors sequences deques fry +search-deques dlists combinators.short-circuit make sets compiler.tree ; IN: compiler.tree.recursive -! Collect label info -GENERIC: collect-label-info ( node -- ) +TUPLE: call-site tail? node label ; -M: #return-recursive collect-label-info - dup label>> (>>return) ; +: recursive-phi-in ( #enter-recursive -- seq ) + [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ; -M: #call-recursive collect-label-info - dup label>> calls>> push ; +> V{ } clone >>calls drop ; +TUPLE: call-graph-node tail? label children calls ; -M: node collect-label-info drop ; - -! A loop is a #recursive which only tail calls itself, and those -! calls are nested inside other loops only. We optimistically -! assume all #recursive nodes are loops, disqualifying them as -! we see evidence to the contrary. : (tail-calls) ( tail? seq -- seq' ) reverse [ swap [ and ] keep ] map nip reverse ; : tail-calls ( tail? node -- seq ) [ - [ #phi? ] - [ #return? ] - [ #return-recursive? ] - tri or or + { + [ #phi? ] + [ #return? ] + [ #return-recursive? ] + } 1|| ] map (tail-calls) ; -SYMBOL: loop-heights -SYMBOL: loop-calls -SYMBOL: loop-stack -SYMBOL: work-list +SYMBOLS: children calls ; -GENERIC: collect-loop-info* ( tail? node -- ) +GENERIC: node-call-graph ( tail? node -- ) -: non-tail-label-info ( nodes -- ) - [ f swap collect-loop-info* ] each ; +: (build-call-graph) ( tail? nodes -- ) + [ tail-calls ] keep + [ node-call-graph ] 2each ; -: (collect-loop-info) ( tail? nodes -- ) - [ tail-calls ] keep [ collect-loop-info* ] 2each ; - -: remember-loop-info ( label -- ) - loop-stack get length swap loop-heights get set-at ; - -M: #recursive collect-loop-info* +: build-call-graph ( nodes -- labels calls ) [ - [ - label>> - [ swap 2array loop-stack [ swap suffix ] change ] - [ remember-loop-info ] - [ t >>loop? drop ] - tri - ] - [ t swap child>> (collect-loop-info) ] bi + V{ } clone children set + V{ } clone calls set + [ t ] dip (build-call-graph) + children get + calls get ] with-scope ; -: current-loop-nesting ( label -- alist ) - loop-stack get swap loop-heights get at tail ; +M: #return-recursive node-call-graph + nip dup label>> (>>return) ; -: disqualify-loop ( label -- ) - work-list get push-front ; +M: #call-recursive node-call-graph + [ dup label>> call-site boa ] keep + [ drop calls get push ] + [ label>> calls>> push ] 2bi ; -M: #call-recursive collect-loop-info* - label>> - swap [ dup disqualify-loop ] unless - dup current-loop-nesting - [ keys [ loop-calls get push-at ] with each ] - [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ] +M: #recursive node-call-graph + [ label>> V{ } clone >>calls drop ] + [ + [ label>> ] [ child>> build-call-graph ] bi + call-graph-node boa children get push + ] bi ; + +M: #branch node-call-graph + children>> [ (build-call-graph) ] with each ; + +M: node node-call-graph 2drop ; + +SYMBOLS: not-loops recursive-nesting ; + +: not-a-loop ( label -- ) not-loops get conjoin ; + +: not-a-loop? ( label -- ? ) not-loops get key? ; + +: non-tail-calls ( call-graph-node -- seq ) + calls>> [ tail?>> not ] filter ; + +: visit-back-edges ( call-graph -- ) + [ + [ non-tail-calls [ label>> not-a-loop ] each ] + [ children>> visit-back-edges ] + bi + ] each ; + +SYMBOL: changed? + +: check-cross-frame-call ( call-site -- ) + label>> dup not-a-loop? [ drop ] [ + recursive-nesting get [ + 2dup label>> eq? [ 2drop f ] [ + [ label>> not-a-loop? ] [ tail?>> not ] bi or + [ not-a-loop changed? on ] [ drop ] if t + ] if + ] with all? drop + ] if ; + +: detect-cross-frame-calls ( call-graph -- ) + ! Suppose we have a nesting of recursives A --> B --> C + ! B tail-calls A, and C non-tail-calls B. Then A cannot be + ! a loop, it needs its own procedure, since the call from + ! C to A crosses a call-frame boundary. + [ + [ recursive-nesting get push ] + [ calls>> [ check-cross-frame-call ] each ] + [ children>> detect-cross-frame-calls ] tri + recursive-nesting get pop* + ] each ; + +: while-changing ( quot: ( -- ) -- ) + changed? off + [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ; + inline recursive + +: detect-loops ( call-graph -- ) + H{ } clone not-loops set + V{ } clone recursive-nesting set + [ visit-back-edges ] + [ '[ _ detect-cross-frame-calls ] while-changing ] bi ; -M: #if collect-loop-info* - children>> [ (collect-loop-info) ] with each ; +: mark-loops ( call-graph -- ) + [ + [ label>> dup not-a-loop? [ t >>loop? ] unless drop ] + [ children>> mark-loops ] + bi + ] each ; -M: #dispatch collect-loop-info* - children>> [ (collect-loop-info) ] with each ; +PRIVATE> -M: node collect-loop-info* 2drop ; - -: collect-loop-info ( node -- ) - { } loop-stack set - H{ } clone loop-calls set - H{ } clone loop-heights set - work-list set - t swap (collect-loop-info) ; - -: disqualify-loops ( -- ) - work-list get [ - dup loop?>> [ - [ f >>loop? drop ] - [ loop-calls get at [ disqualify-loop ] each ] - bi - ] [ drop ] if - ] slurp-deque ; +SYMBOL: call-graph : analyze-recursive ( nodes -- nodes ) - dup [ collect-label-info ] each-node - dup collect-loop-info disqualify-loops ; + dup build-call-graph drop + [ call-graph set ] + [ detect-loops ] + [ mark-loops ] + tri ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index c73f2211f0..7fa096b623 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -165,9 +165,6 @@ M: #shuffle inputs/outputs mapping>> unzip swap ; M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ; M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; -: recursive-phi-in ( #enter-recursive -- seq ) - [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; - : ends-with-terminate? ( nodes -- ? ) [ f ] [ last #terminate? ] if-empty ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index a96fc0501d..d73368867d 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -1,4 +1,3 @@ -IN: compiler.tree.tuple-unboxing.tests USING: tools.test compiler.tree compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation @@ -7,6 +6,7 @@ compiler.tree.tuple-unboxing compiler.tree.checker compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private slots.private ; +IN: compiler.tree.tuple-unboxing.tests : test-unboxing ( quot -- ) build-tree diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 6bed4407b8..de2848ea78 100755 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -1,12 +1,15 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs accessors kernel combinators +USING: namespaces assocs accessors kernel kernel.private combinators classes.algebra sequences slots.private fry vectors classes.tuple.private math math.private arrays -stack-checker.branches +stack-checker.branches stack-checker.values compiler.utilities compiler.tree +compiler.tree.builder +compiler.tree.cleanup compiler.tree.combinators +compiler.tree.propagation compiler.tree.propagation.info compiler.tree.escape-analysis.simple compiler.tree.escape-analysis.allocations ; @@ -72,8 +75,8 @@ M: #call unbox-tuples* } case ; M: #declare unbox-tuples* - #! We don't look at declarations after propagation anyway. - f >>declaration ; + #! We don't look at declarations after escape analysis anyway. + drop f ; M: #copy unbox-tuples* [ flatten-values ] change-in-d @@ -113,6 +116,44 @@ M: #return-recursive unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d ; +: value-declaration ( value -- quot ) + value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ; + +: unbox-parameter-quot ( allocation -- quot ) + dup unboxed-allocation { + { [ dup not ] [ 2drop [ ] ] } + { [ dup array? ] [ + [ value-declaration ] [ + [ + [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi* + prepose + ] map-index + ] bi* '[ @ _ cleave ] + ] } + } cond ; + +: unbox-parameters-quot ( values -- quot ) + [ unbox-parameter-quot ] map + dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ; + +: unbox-parameters-nodes ( new-values old-values -- nodes ) + [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ; + +: new-and-old-values ( values -- new-values old-values ) + [ length [ ] replicate ] keep ; + +: unbox-hairy-introduce ( #introduce -- nodes ) + dup out-d>> new-and-old-values + [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi + swap prefix propagate ; + +M: #introduce unbox-tuples* + ! For every output that is unboxed, insert slot accessors + ! to convert the stack value into its unboxed form + dup out-d>> [ unboxed-allocation ] any? [ + unbox-hairy-introduce + ] when ; + ! These nodes never participate in unboxing : assert-not-unboxed ( values -- ) dup array? @@ -123,8 +164,6 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; M: #return unbox-tuples* dup in-d>> assert-not-unboxed ; -M: #introduce unbox-tuples* dup out-d>> assert-not-unboxed ; - M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ; M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ; diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index c6b7b2adc5..d8df81fc0d 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -9,7 +9,7 @@ IN: compiler.utilities dup '[ @ [ - dup array? + dup [ array? ] [ vector? ] bi or [ _ push-all ] [ _ push ] if ] when* ] @@ -26,8 +26,12 @@ SYMBOL: yield-hook yield-hook [ [ ] ] initialize -: alist-max ( alist -- pair ) - [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; +: alist-most ( alist quot -- pair ) + [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline + +: alist-min ( alist -- pair ) [ before? ] alist-most ; + +: alist-max ( alist -- pair ) [ after? ] alist-most ; : penultimate ( seq -- elt ) [ length 2 - ] keep nth ; diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 9ece36e6cd..2df4dce916 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -17,8 +17,8 @@ TUPLE: huffman-code { code } ; : ( -- code ) 0 0 0 huffman-code boa ; -: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ; -: next-code ( code -- ) [ 1+ ] change-code drop ; +: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ; +: next-code ( code -- ) [ 1 + ] change-code drop ; :: all-patterns ( huff n -- seq ) n log2 huff size>> - :> free-bits diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 05ec94a794..ff38f94c68 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -64,7 +64,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } k swap - dup k! 0 > ] [ ] produce swap suffix - { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap append ] bi* ] [ suffix ] if ] reduce + { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap append ] bi* ] [ suffix ] if ] reduce [ dup array? [ second 0 ] [ 1array ] if ] map concat nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; @@ -91,14 +91,14 @@ CONSTANT: dist-table } : nth* ( n seq -- elt ) - [ length 1- swap - ] [ nth ] bi ; + [ length 1 - swap - ] [ nth ] bi ; :: inflate-lz77 ( seq -- bytes ) 1000 :> bytes seq [ dup array? - [ first2 '[ _ 1- bytes nth* bytes push ] times ] + [ first2 '[ _ 1 - bytes nth* bytes push ] times ] [ bytes push ] if ] each bytes ; diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor deleted file mode 100644 index 698e35d87e..0000000000 --- a/basis/compression/lzw/lzw-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors tools.test compression.lzw ; -IN: compression.lzw.tests diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 1c2dea2d79..d3f3229171 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math concurrency.mailboxes threads sequences accessors arrays math.parser ; +IN: concurrency.combinators.tests [ [ drop ] parallel-each ] must-infer { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as @@ -49,7 +49,7 @@ math.parser ; [ "1a" "4b" "3c" ] [ 2 - { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave + { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave [ number>string ] 3 parallel-napply { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread ] unit-test diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index d79cfbf1c9..d88fcef609 100644 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -23,7 +23,7 @@ ERROR: count-down-already-done ; : count-down ( count-down -- ) dup n>> dup zero? [ count-down-already-done ] - [ 1- >>n count-down-check ] if ; + [ 1 - >>n count-down-check ] if ; : await-timeout ( count-down timeout -- ) [ promise>> ] dip ?promise-timeout ?linked t assert= ; diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 6c0d882cac..b2a2851926 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -1,9 +1,9 @@ -IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files io.files.temp io.directories arrays io.sockets system combinators threads math sequences concurrency.messaging continuations accessors prettyprint ; FROM: concurrency.messaging => receive send ; +IN: concurrency.distributed.tests : test-node ( -- addrspec ) { diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index 7ec9db8ad9..a8214cf42f 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -1,8 +1,8 @@ -IN: concurrency.exchangers.tests USING: tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; FROM: sequences => 3append ; +IN: concurrency.exchangers.tests :: exchanger-test ( -- string ) [let | diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 05ff74b03f..4fc00b71dd 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -1,6 +1,6 @@ -IN: concurrency.flags.tests USING: tools.test concurrency.flags concurrency.combinators kernel threads locals accessors calendar ; +IN: concurrency.flags.tests :: flag-test-1 ( -- val ) [let | f [ ] | diff --git a/basis/concurrency/futures/futures-tests.factor b/basis/concurrency/futures/futures-tests.factor index 208a72f820..07466e5ffd 100644 --- a/basis/concurrency/futures/futures-tests.factor +++ b/basis/concurrency/futures/futures-tests.factor @@ -1,5 +1,5 @@ -IN: concurrency.futures.tests USING: concurrency.futures kernel tools.test threads ; +IN: concurrency.futures.tests [ 50 ] [ [ 50 ] future ?future diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 8f82aa88ba..f199876fd0 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar accessors ; +IN: concurrency.locks.tests :: lock-test-0 ( -- v ) [let | v [ V{ } clone ] diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 0094f3323d..18cd86fa53 100644 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -57,7 +57,7 @@ TUPLE: rw-lock readers writers reader# writer ; > @@ -68,7 +68,7 @@ TUPLE: rw-lock readers writers reader# writer ; writers>> notify-1 ; : remove-reader ( lock -- ) - [ 1- ] change-reader# drop ; + [ 1 - ] change-reader# drop ; : release-read-lock ( lock -- ) dup remove-reader diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 81e54f1807..56d579d6c7 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.mailboxes.tests USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; +IN: concurrency.mailboxes.tests { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as @@ -86,4 +86,4 @@ continuations calendar destructors ; [ 1 seconds mailbox-get-timeout ] [ wait-timeout? ] must-fail-with - \ No newline at end of file + diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 200adb14ae..419277647d 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: concurrency.mailboxes USING: dlists deques threads sequences continuations destructors namespaces math quotations words kernel arrays assocs init system concurrency.conditions accessors debugger debugger.threads locals fry ; +IN: concurrency.mailboxes TUPLE: mailbox threads data disposed ; diff --git a/basis/concurrency/promises/promises-tests.factor b/basis/concurrency/promises/promises-tests.factor index 36fe4ef907..353f4a69b7 100644 --- a/basis/concurrency/promises/promises-tests.factor +++ b/basis/concurrency/promises/promises-tests.factor @@ -1,6 +1,6 @@ -IN: concurrency.promises.tests USING: vectors concurrency.promises kernel threads sequences tools.test ; +IN: concurrency.promises.tests [ V{ 50 50 50 } ] [ 0 diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index 59518f4c8d..dcd0ed9a2c 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/basis/concurrency/semaphores/semaphores.factor @@ -21,13 +21,13 @@ M: negative-count-semaphore summary : acquire-timeout ( semaphore timeout -- ) over count>> zero? [ dupd wait-to-acquire ] [ drop ] if - [ 1- ] change-count drop ; + [ 1 - ] change-count drop ; : acquire ( semaphore -- ) f acquire-timeout ; : release ( semaphore -- ) - [ 1+ ] change-count + [ 1 + ] change-count threads>> notify-1 ; :: with-semaphore-timeout ( semaphore timeout quot -- ) diff --git a/basis/cords/cords-tests.factor b/basis/cords/cords-tests.factor index 0058c8f07a..898e4e51c8 100644 --- a/basis/cords/cords-tests.factor +++ b/basis/cords/cords-tests.factor @@ -1,5 +1,5 @@ -IN: cords.tests USING: cords strings tools.test kernel sequences ; +IN: cords.tests [ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test [ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test diff --git a/basis/core-foundation/numbers/numbers-tests.factor b/basis/core-foundation/numbers/numbers-tests.factor deleted file mode 100644 index 1c50f2dcb2..0000000000 --- a/basis/core-foundation/numbers/numbers-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-foundation.numbers ; -IN: core-foundation.numbers.tests diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index a63a3ea674..6446eacd08 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -103,7 +103,7 @@ TUPLE: run-loop fds sources timers ; : (reset-timer) ( timer counter -- ) yield { { [ dup 0 = ] [ now ((reset-timer)) ] } - { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] } + { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] } { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] } [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ] } cond ; diff --git a/basis/core-foundation/utilities/utilities-tests.factor b/basis/core-foundation/utilities/utilities-tests.factor deleted file mode 100644 index fb3deb2ca5..0000000000 --- a/basis/core-foundation/utilities/utilities-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-foundation.utilities ; -IN: core-foundation.utilities.tests diff --git a/basis/core-graphics/types/types-tests.factor b/basis/core-graphics/types/types-tests.factor deleted file mode 100644 index d3b081fccc..0000000000 --- a/basis/core-graphics/types/types-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-graphics.types ; -IN: core-graphics.types.tests diff --git a/basis/core-text/fonts/fonts-tests.factor b/basis/core-text/fonts/fonts-tests.factor deleted file mode 100644 index 45fa2bcdc0..0000000000 --- a/basis/core-text/fonts/fonts-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text.fonts ; -IN: core-text.fonts.tests diff --git a/basis/core-text/utilities/utilities-tests.factor b/basis/core-text/utilities/utilities-tests.factor deleted file mode 100644 index 65914a3fcd..0000000000 --- a/basis/core-text/utilities/utilities-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text.utilities ; -IN: core-text.utilities.tests diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index e4c8f3246d..7bb9caec9b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,43 +1,57 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic kernel kernel.private math memory namespaces make sequences layouts system hashtables classes alien byte-arrays combinators words sets fry ; IN: cpu.architecture +! Representations -- these are like low-level types + +! Unknown representation; this is used for ##copy instructions which +! get eliminated later +SINGLETON: any-rep + +! Integer registers can contain data with one of these three representations +! tagged-rep: tagged pointer or fixnum +! int-rep: untagged fixnum, not a pointer +SINGLETONS: tagged-rep int-rep ; + +! Floating point registers can contain data with +! one of these representations +SINGLETONS: single-float-rep double-float-rep ; + +UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ; + ! Register classes -SINGLETON: int-regs -SINGLETON: single-float-regs -SINGLETON: double-float-regs -UNION: float-regs single-float-regs double-float-regs ; +SINGLETONS: int-regs float-regs ; + UNION: reg-class int-regs float-regs ; +CONSTANT: reg-classes { int-regs float-regs } ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params -GENERIC: reg-size ( register-class -- n ) +: reg-class-of ( rep -- reg-class ) + { + { tagged-rep [ int-regs ] } + { int-rep [ int-regs ] } + { single-float-rep [ float-regs ] } + { double-float-rep [ float-regs ] } + { stack-params [ stack-params ] } + } case ; -M: int-regs reg-size drop cell ; - -M: single-float-regs reg-size drop 4 ; - -M: double-float-regs reg-size drop 8 ; - -M: stack-params reg-size drop cell ; +: rep-size ( rep -- n ) + { + { tagged-rep [ cell ] } + { int-rep [ cell ] } + { single-float-rep [ 4 ] } + { double-float-rep [ 8 ] } + { stack-params [ cell ] } + } case ; ! Mapping from register class to machine registers HOOK: machine-registers cpu ( -- assoc ) -! Return values of this class go here -GENERIC: return-reg ( register-class -- reg ) - -! Sequence of registers used for parameter passing in class -GENERIC: param-regs ( register-class -- regs ) - -GENERIC: param-reg ( n register-class -- reg ) - -M: object param-reg param-regs nth ; - HOOK: two-operand? cpu ( -- ? ) HOOK: %load-immediate cpu ( reg obj -- ) @@ -100,8 +114,7 @@ HOOK: %div-float cpu ( dst src1 src2 -- ) HOOK: %integer>float cpu ( dst src -- ) HOOK: %float>integer cpu ( dst src -- ) -HOOK: %copy cpu ( dst src -- ) -HOOK: %copy-float cpu ( dst src -- ) +HOOK: %copy cpu ( dst src rep -- ) HOOK: %unbox-float cpu ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) HOOK: %box-float cpu ( dst src temp -- ) @@ -146,15 +159,27 @@ HOOK: %compare-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-branch cpu ( label cc src1 src2 -- ) -HOOK: %spill-integer cpu ( src n -- ) -HOOK: %spill-float cpu ( src n -- ) -HOOK: %reload-integer cpu ( dst n -- ) -HOOK: %reload-float cpu ( dst n -- ) +HOOK: %spill cpu ( src n rep -- ) +HOOK: %reload cpu ( dst n rep -- ) HOOK: %loop-entry cpu ( -- ) ! FFI stuff +! Return values of this class go here +GENERIC: return-reg ( reg-class -- reg ) + +! Sequence of registers used for parameter passing in class +GENERIC: param-regs ( reg-class -- regs ) + +M: stack-params param-regs drop f ; + +GENERIC: param-reg ( n reg-class -- reg ) + +M: reg-class param-reg param-regs nth ; + +M: stack-params param-reg drop ; + ! Is this integer small enough to appear in value template ! slots? HOOK: small-enough? cpu ( n -- ? ) @@ -176,7 +201,7 @@ HOOK: dummy-fp-params? cpu ( -- ? ) HOOK: %prepare-unbox cpu ( -- ) -HOOK: %unbox cpu ( n reg-class func -- ) +HOOK: %unbox cpu ( n rep func -- ) HOOK: %unbox-long-long cpu ( n func -- ) @@ -184,7 +209,7 @@ HOOK: %unbox-small-struct cpu ( c-type -- ) HOOK: %unbox-large-struct cpu ( n c-type -- ) -HOOK: %box cpu ( n reg-class func -- ) +HOOK: %box cpu ( n rep func -- ) HOOK: %box-long-long cpu ( n func -- ) @@ -194,9 +219,9 @@ HOOK: %box-small-struct cpu ( c-type -- ) HOOK: %box-large-struct cpu ( n c-type -- ) -GENERIC: %save-param-reg ( stack reg reg-class -- ) +HOOK: %save-param-reg cpu ( stack reg rep -- ) -GENERIC: %load-param-reg ( stack reg reg-class -- ) +HOOK: %load-param-reg cpu ( stack reg rep -- ) HOOK: %prepare-alien-invoke cpu ( -- ) @@ -222,7 +247,3 @@ HOOK: %callback-value cpu ( ctype -- ) HOOK: %callback-return cpu ( params -- ) M: object %callback-return drop %return ; - -M: stack-params param-reg drop ; - -M: stack-params param-regs drop f ; diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 23b1d1e6f4..6ee1c84558 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -1,7 +1,7 @@ -IN: cpu.ppc.assembler.tests USING: cpu.ppc.assembler tools.test arrays kernel namespaces make vocabs sequences ; FROM: cpu.ppc.assembler => B ; +IN: cpu.ppc.assembler.tests : test-assembler ( expected quot -- ) [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index cbb914121e..c63372fa3f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -226,7 +226,7 @@ CONSTANT: rs-reg 14 ! key = class 5 4 MR ! key &= cache.length - 1 - 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI ! cache += array-start-offset 3 3 array-start-offset ADDI ! cache += key diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 14d271c31c..a169982445 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -32,7 +32,7 @@ enable-float-intrinsics M: ppc machine-registers { { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } - { double-float-regs $[ 0 29 [a,b] ] } + { float-regs $[ 0 29 [a,b] ] } } ; CONSTANT: scratch-reg 30 @@ -217,7 +217,7 @@ M:: ppc %integer>bignum ( dst src temp -- ) temp dst 1 bignum@ STW ! Compute sign temp src MR - temp temp cell-bits 1- SRAWI + temp temp cell-bits 1 - SRAWI temp temp 1 ANDI ! Store sign temp dst 2 bignum@ STW @@ -493,26 +493,18 @@ M: float-regs return-reg drop 1 ; M: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ; -GENERIC: STF ( src dst off reg-class -- ) +M: single-float-rep %save-param-reg drop 1 rot local@ STFS ; +M: single-float-rep %load-param-reg 1 rot local@ LFS ; -M: single-float-regs STF drop STFS ; -M: double-float-regs STF drop STFD ; +M: double-float-rep %save-param-reg drop 1 rot local@ STFD ; +M: double-float-rep %load-param-reg 1 rot local@ LFD ; -M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ; - -GENERIC: LF ( dst src off reg-class -- ) - -M: single-float-regs LF drop LFS ; -M: double-float-regs LF drop LFD ; - -M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ; - -M: stack-params %load-param-reg ( stack reg reg-class -- ) +M: stack-params %load-param-reg ( stack reg rep -- ) drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ; : next-param@ ( n -- x ) param@ stack-frame get total-size>> + ; -M: stack-params %save-param-reg ( stack reg reg-class -- ) +M: stack-params %save-param-reg ( stack reg rep -- ) #! Funky. Read the parameter from the caller's stack frame. #! This word is used in callbacks drop @@ -524,12 +516,12 @@ M: ppc %prepare-unbox ( -- ) 3 ds-reg 0 LWZ ds-reg dup cell SUBI ; -M: ppc %unbox ( n reg-class func -- ) +M: ppc %unbox ( n rep func -- ) ! Value must be in r3 ! Call the unboxer f %alien-invoke ! Store the return value on the C stack - over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; + over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ; M: ppc %unbox-long-long ( n func -- ) ! Value must be in r3:r4 @@ -548,11 +540,11 @@ M: ppc %unbox-large-struct ( n c-type -- ) ! Call the function "to_value_struct" f %alien-invoke ; -M: ppc %box ( n reg-class func -- ) +M: ppc %box ( n rep func -- ) ! If the source is a stack location, load it into freg #0. ! If the source is f, then we assume the value is already in ! freg #0. - [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip + [ over [ 0 over reg-class-of param-reg swap %load-param-reg ] [ 2drop ] if ] dip f %alien-invoke ; M: ppc %box-long-long ( n func -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 76699c1306..bd03b47302 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -10,21 +10,18 @@ cpu.x86.assembler.operands cpu.x86 cpu.architecture ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. -! OS X requires that the stack be 16-byte aligned, and we do -! this on all platforms, sacrificing some stack space for -! code simplicity. +! OS X requires that the stack be 16-byte aligned. M: x86.32 machine-registers { { int-regs { EAX ECX EDX EBP EBX } } - { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } + { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } } ; M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; -M: x86.32 temp-reg-1 ECX ; -M: x86.32 temp-reg-2 EDX ; +M: x86.32 temp-reg ECX ; M:: x86.32 %dispatch ( src temp -- ) ! Load jump table base. @@ -63,29 +60,23 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? ) ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; M: int-regs param-regs drop { } ; -M: int-regs push-return-reg return-reg PUSH ; - -M: int-regs load-return-reg - return-reg swap next-stack@ MOV ; - -M: int-regs store-return-reg - [ stack@ ] [ return-reg ] bi* MOV ; - M: float-regs param-regs drop { } ; -: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ; +GENERIC: push-return-reg ( rep -- ) +GENERIC: load-return-reg ( n rep -- ) +GENERIC: store-return-reg ( n rep -- ) -M: float-regs push-return-reg - stack-reg swap reg-size - [ SUB ] [ [ [] ] dip FSTP ] 2bi ; +M: int-rep push-return-reg drop EAX PUSH ; +M: int-rep load-return-reg drop EAX swap next-stack@ MOV ; +M: int-rep store-return-reg drop stack@ EAX MOV ; -: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ; +M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ; +M: single-float-rep load-return-reg drop next-stack@ FLDS ; +M: single-float-rep store-return-reg drop stack@ FSTPS ; -M: float-regs load-return-reg - [ next-stack@ ] [ reg-size ] bi* FLD ; - -M: float-regs store-return-reg - [ stack@ ] [ reg-size ] bi* FSTP ; +M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ; +M: double-float-rep load-return-reg drop next-stack@ FLDL ; +M: double-float-rep store-return-reg drop stack@ FSTPL ; : align-sub ( n -- ) [ align-stack ] keep - decr-stack-reg ; @@ -101,21 +92,21 @@ M: x86.32 %prologue ( n -- ) 0 PUSH rc-absolute-cell rel-this 3 cells - decr-stack-reg ; -M: object %load-param-reg 3drop ; +M: x86.32 %load-param-reg 3drop ; -M: object %save-param-reg 3drop ; +M: x86.32 %save-param-reg 3drop ; -: (%box) ( n reg-class -- ) +: (%box) ( n rep -- ) #! If n is f, push the return register onto the stack; we #! are boxing a return value of a C function. If n is an #! integer, push [ESP+n] on the stack; we are boxing a #! parameter being passed to a callback from C. over [ load-return-reg ] [ 2drop ] if ; -M:: x86.32 %box ( n reg-class func -- ) - n reg-class (%box) - reg-class reg-size [ - reg-class push-return-reg +M:: x86.32 %box ( n rep func -- ) + n rep (%box) + rep rep-size [ + rep push-return-reg func f %alien-invoke ] with-aligned-stack ; @@ -165,7 +156,7 @@ M: x86.32 %prepare-unbox ( -- ) EAX ESI [] MOV ESI 4 SUB ; -: (%unbox) ( func -- ) +: call-unbox-func ( func -- ) 4 [ ! Push parameter EAX PUSH @@ -173,17 +164,17 @@ M: x86.32 %prepare-unbox ( -- ) f %alien-invoke ] with-aligned-stack ; -M: x86.32 %unbox ( n reg-class func -- ) +M: x86.32 %unbox ( n rep func -- ) #! The value being unboxed must already be in EAX. #! If n is f, we're unboxing a return value about to be #! returned by the callback. Otherwise, we're unboxing #! a parameter to a C function about to be called. - (%unbox) + call-unbox-func ! Store the return value on the C stack over [ store-return-reg ] [ 2drop ] if ; M: x86.32 %unbox-long-long ( n func -- ) - (%unbox) + call-unbox-func ! Store the return value on the C stack [ dup stack@ EAX MOV diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index f837c7de73..7c832fe66c 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -11,7 +11,7 @@ IN: cpu.x86.64 M: x86.64 machine-registers { { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } - { double-float-regs { + { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 } } @@ -46,20 +46,21 @@ M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; M: x86.64 %prologue ( n -- ) - temp-reg-1 0 MOV rc-absolute-cell rel-this + temp-reg 0 MOV rc-absolute-cell rel-this dup PUSH - temp-reg-1 PUSH + temp-reg PUSH stack-reg swap 3 cells - SUB ; -M: stack-params %load-param-reg +M: stack-params copy-register* drop - [ R11 swap param@ MOV ] dip - param@ R11 MOV ; + { + { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] } + { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] } + } cond ; -M: stack-params %save-param-reg - drop - R11 swap next-stack@ MOV - param@ R11 MOV ; +M: x86 %save-param-reg [ param@ ] 2dip copy-register ; + +M: x86 %load-param-reg [ swap param@ ] dip copy-register ; : with-return-regs ( quot -- ) [ @@ -73,20 +74,22 @@ M: x86.64 %prepare-unbox ( -- ) param-reg-1 R14 [] MOV R14 cell SUB ; -M: x86.64 %unbox ( n reg-class func -- ) +M:: x86.64 %unbox ( n rep func -- ) ! Call the unboxer - f %alien-invoke - ! Store the return value on the C stack - over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; + func f %alien-invoke + ! Store the return value on the C stack if this is an + ! alien-invoke, otherwise leave it the return register if + ! this is the end of alien-callback + n [ n rep reg-class-of return-reg rep %save-param-reg ] when ; M: x86.64 %unbox-long-long ( n func -- ) - int-regs swap %unbox ; + [ int-rep ] dip %unbox ; : %unbox-struct-field ( c-type i -- ) ! Alien must be in param-reg-1. - R11 swap cells [+] swap reg-class>> { + R11 swap cells [+] swap rep>> reg-class-of { { int-regs [ int-regs get pop swap MOV ] } - { double-float-regs [ float-regs get pop swap MOVSD ] } + { float-regs [ float-regs get pop swap MOVSD ] } } case ; M: x86.64 %unbox-small-struct ( c-type -- ) @@ -109,27 +112,31 @@ M: x86.64 %unbox-large-struct ( n c-type -- ) ! Copy the struct to the C stack "to_value_struct" f %alien-invoke ; -: load-return-value ( reg-class -- ) - 0 over param-reg swap return-reg - 2dup eq? [ 2drop ] [ MOV ] if ; +: load-return-value ( rep -- ) + [ [ 0 ] dip reg-class-of param-reg ] + [ reg-class-of return-reg ] + [ ] + tri copy-register ; -M: x86.64 %box ( n reg-class func -- ) - rot [ - rot [ 0 swap param-reg ] keep %load-param-reg +M:: x86.64 %box ( n rep func -- ) + n [ + n + 0 rep reg-class-of param-reg + rep %load-param-reg ] [ - swap load-return-value - ] if* - f %alien-invoke ; + rep load-return-value + ] if + func f %alien-invoke ; M: x86.64 %box-long-long ( n func -- ) - int-regs swap %box ; + [ int-rep ] dip %box ; -: box-struct-field@ ( i -- operand ) 1+ cells param@ ; +: box-struct-field@ ( i -- operand ) 1 + cells param@ ; : %box-struct-field ( c-type i -- ) - box-struct-field@ swap reg-class>> { + box-struct-field@ swap c-type-rep reg-class-of { { int-regs [ int-regs get pop MOV ] } - { double-float-regs [ float-regs get pop MOVSD ] } + { float-regs [ float-regs get pop MOVSD ] } } case ; M: x86.64 %box-small-struct ( c-type -- ) diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 7ab25b6d3f..e06c026d39 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -6,7 +6,8 @@ cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen compiler.cfg.registers ; IN: cpu.x86.64.unix -M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; +M: int-regs param-regs + drop { RDI RSI RDX RCX R8 R9 } ; M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; @@ -15,7 +16,7 @@ M: x86.64 reserved-area-size 0 ; ! The ABI for passing structs by value is pretty messed up << "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type (>>reg-class) >> +stack-params "__stack_value" c-type (>>rep) >> : struct-types&offset ( struct-type -- pairs ) fields>> [ @@ -29,7 +30,7 @@ stack-params "__stack_value" c-type (>>reg-class) >> : flatten-small-struct ( c-type -- seq ) struct-types&offset split-struct [ - [ c-type c-type-reg-class ] map + [ c-type c-type-rep reg-class-of ] map int-regs swap member? "void*" "double" ? c-type ] map ; @@ -53,6 +54,4 @@ M: x86.64 dummy-int-params? f ; M: x86.64 dummy-fp-params? f ; -M: x86.64 temp-reg-1 R8 ; - -M: x86.64 temp-reg-2 R9 ; +M: x86.64 temp-reg R8 ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 44e8568658..d9f83612e6 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -22,9 +22,7 @@ M: x86.64 dummy-int-params? t ; M: x86.64 dummy-fp-params? t ; -M: x86.64 temp-reg-1 RAX ; - -M: x86.64 temp-reg-2 RCX ; +M: x86.64 temp-reg RAX ; << "longlong" "ptrdiff_t" typedef diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 2b99513fc1..b2de0cc6e4 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -606,6 +606,8 @@ ALIAS: PINSRQ PINSRD : PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; : PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; + + : PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ; : PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ; : PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ; diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index d3cb66ff12..df49ae0a15 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -26,15 +26,11 @@ REGISTERS: 128 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ; - ; ! Addressing modes diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 6363f17e48..0dafc3d9c4 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -226,7 +226,7 @@ big-endian off temp2 temp1 MOV bootstrap-cell 8 = [ temp2 1 SHL ] when ! key &= cache.length - 1 - temp2 mega-cache-size get 1- bootstrap-cell * AND + temp2 mega-cache-size get 1 - bootstrap-cell * AND ! cache += array-start-offset temp0 array-start-offset ADD ! cache += key @@ -496,7 +496,7 @@ big-endian off ! make a copy mod-arg div-arg MOV ! sign-extend - mod-arg bootstrap-cell-bits 1- SAR + mod-arg bootstrap-cell-bits 1 - SAR ! divide temp3 IDIV ; diff --git a/basis/cpu/x86/features/features-tests.factor b/basis/cpu/x86/features/features-tests.factor index 69847cacfa..680e655995 100644 --- a/basis/cpu/x86/features/features-tests.factor +++ b/basis/cpu/x86/features/features-tests.factor @@ -1,7 +1,7 @@ -IN: cpu.x86.features.tests USING: cpu.x86.features tools.test kernel sequences math system ; +IN: cpu.x86.features.tests cpu x86? [ [ t ] [ sse2? { t f } member? ] unit-test [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test -] when \ No newline at end of file +] when diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 34b1b63581..a6c958083c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -30,9 +30,7 @@ HOOK: reserved-area-size cpu ( -- n ) : param@ ( n -- op ) reserved-area-size + stack@ ; -: spill-integer@ ( n -- op ) spill-integer-offset param@ ; - -: spill-float@ ( n -- op ) spill-float-offset param@ ; +: spill@ ( n -- op ) spill-offset param@ ; : gc-root@ ( n -- op ) gc-root-offset param@ ; @@ -48,9 +46,11 @@ HOOK: reserved-area-size cpu ( -- n ) M: x86 stack-frame-size ( stack-frame -- i ) (stack-frame-size) 3 cells reserved-area-size + + align-stack ; -HOOK: temp-reg-1 cpu ( -- reg ) -HOOK: temp-reg-2 cpu ( -- reg ) +! Must be a volatile register not used for parameter passing, for safe +! use in calls in and out of C +HOOK: temp-reg cpu ( -- reg ) +! Fastcall calling convention HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) @@ -126,9 +126,6 @@ M: x86 %sar-imm nip SAR ; M: x86 %not drop NOT ; M: x86 %log2 BSR ; -: ?MOV ( dst src -- ) - 2dup = [ 2drop ] [ MOV ] if ; inline - :: overflow-template ( label dst src1 src2 insn -- ) src1 src2 insn call label JO ; inline @@ -165,7 +162,7 @@ M:: x86 %integer>bignum ( dst src temp -- ) dst 3 bignum@ src MOV ! Compute sign temp src MOV - temp cell-bits 1- SAR + temp cell-bits 1 - SAR temp 1 AND ! Store sign dst 2 bignum@ temp MOV @@ -210,10 +207,17 @@ M: x86 %div-float nip DIVSD ; M: x86 %integer>float CVTSI2SD ; M: x86 %float>integer CVTTSD2SI ; -M: x86 %copy ( dst src -- ) ?MOV ; +GENERIC: copy-register* ( dst src rep -- ) -M: x86 %copy-float ( dst src -- ) - 2dup = [ 2drop ] [ MOVSD ] if ; +M: int-rep copy-register* drop MOV ; +M: tagged-rep copy-register* drop MOV ; +M: single-float-rep copy-register* drop MOVSS ; +M: double-float-rep copy-register* drop MOVSD ; + +: copy-register ( dst src rep -- ) + 2over eq? [ 3drop ] [ copy-register* ] if ; + +M: x86 %copy ( dst src rep -- ) copy-register ; M: x86 %unbox-float ( dst src -- ) float-offset [+] MOVSD ; @@ -301,6 +305,9 @@ M: x86.64 has-small-reg? 2drop t ; [ quot call ] with-save/restore ] if ; inline +: ?MOV ( dst src -- ) + 2dup = [ 2drop ] [ MOV ] if ; inline + M:: x86 %string-nth ( dst src index temp -- ) ! We request a small-reg of size 8 since those of size 16 are ! a superset. @@ -512,39 +519,21 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) { cc/= [ JNE ] } } case ; -M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ; -M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ; - -M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ; -M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; +M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ; +M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M: int-regs %save-param-reg drop [ param@ ] dip MOV ; -M: int-regs %load-param-reg drop swap param@ MOV ; - -GENERIC: MOVSS/D ( dst src reg-class -- ) - -M: single-float-regs MOVSS/D drop MOVSS ; -M: double-float-regs MOVSS/D drop MOVSD ; - -M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ; -M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ; - -GENERIC: push-return-reg ( reg-class -- ) -GENERIC: load-return-reg ( n reg-class -- ) -GENERIC: store-return-reg ( n reg-class -- ) - M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - temp-reg-1 "stack_chain" f %alien-global - temp-reg-1 temp-reg-1 [] MOV - temp-reg-1 [] stack-reg MOV - temp-reg-1 [] cell SUB - temp-reg-1 2 cells [+] ds-reg MOV - temp-reg-1 3 cells [+] rs-reg MOV ; + temp-reg "stack_chain" f %alien-global + temp-reg temp-reg [] MOV + temp-reg [] stack-reg MOV + temp-reg [] cell SUB + temp-reg 2 cells [+] ds-reg MOV + temp-reg 3 cells [+] rs-reg MOV ; M: x86 value-struct? drop t ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index c4aa47d383..e9aa01feb4 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -75,7 +75,7 @@ M: db-connection ( class -- statement ) M: random-id-generator eval-generator ( singleton -- obj ) drop system-random-generator get [ - 63 [ random-bits ] keep 1- set-bit + 63 [ random-bits ] keep 1 - set-bit ] with-random ; : interval-comparison ( ? str -- str ) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 6bf8dd3075..7f109d80e0 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -469,7 +469,7 @@ TUPLE: bignum-test id m n o ; } define-persistent [ bignum-test drop-table ] ignore-errors [ ] [ bignum-test ensure-table ] unit-test - [ ] [ 63 2^ 1- dup dup insert-tuple ] unit-test ; + [ ] [ 63 2^ 1 - dup dup insert-tuple ] unit-test ; ! sqlite only ! [ T{ bignum-test f 1 diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index 08f84d9335..6800c83a9c 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -1,7 +1,7 @@ -IN: debugger.tests USING: debugger kernel continuations tools.test ; +IN: debugger.tests [ ] [ [ drop ] [ error. ] recover ] unit-test [ f ] [ { } vm-error? ] unit-test -[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file +[ f ] [ { "A" "B" } vm-error? ] unit-test diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 6c0985ce06..ce9496291c 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -36,7 +36,7 @@ M: string error. print ; error-continuation get name>> assoc-stack ; : :res ( n -- * ) - 1- restarts get-global nth f restarts set-global restart ; + 1 - restarts get-global nth f restarts set-global restart ; : :1 ( -- * ) 1 :res ; : :2 ( -- * ) 2 :res ; @@ -44,7 +44,7 @@ M: string error. print ; : restart. ( restart n -- ) [ - 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if + 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if name>> % ] "" make print ; @@ -92,7 +92,7 @@ HOOK: signal-error. os ( obj -- ) : array-size-error. ( obj -- ) "Invalid array size: " write dup third . - "Maximum: " write fourth 1- . ; + "Maximum: " write fourth 1 - . ; : c-string-error. ( obj -- ) "Cannot convert to C string: " write third . ; diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor index 212908b2fd..1eb916487c 100644 --- a/basis/debugger/unix/unix.factor +++ b/basis/debugger/unix/unix.factor @@ -13,7 +13,7 @@ CONSTANT: signal-names "SIGUSR1" "SIGUSR2" } -: signal-name ( n -- str/f ) 1- signal-names ?nth ; +: signal-name ( n -- str/f ) 1 - signal-names ?nth ; : signal-name. ( n -- ) signal-name [ " (" ")" surround write ] when* ; diff --git a/basis/definitions/icons/icons-tests.factor b/basis/definitions/icons/icons-tests.factor deleted file mode 100644 index 47e106f8ec..0000000000 --- a/basis/definitions/icons/icons-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test definitions.icons ; -IN: definitions.icons.tests diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 9f9aca8702..d9581152e1 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -55,8 +55,8 @@ PROTOCOL: beta three ; TUPLE: hey value ; C: hey -CONSULT: alpha hey value>> 1+ ; -CONSULT: beta hey value>> 1- ; +CONSULT: alpha hey value>> 1 + ; +CONSULT: beta hey value>> 1 - ; [ 2 ] [ 1 one ] unit-test [ 2 ] [ 1 two ] unit-test diff --git a/basis/disjoint-sets/disjoint-sets-tests.factor b/basis/disjoint-sets/disjoint-sets-tests.factor index 74746f1a3a..cb9233343e 100644 --- a/basis/disjoint-sets/disjoint-sets-tests.factor +++ b/basis/disjoint-sets/disjoint-sets-tests.factor @@ -1,5 +1,5 @@ -IN: disjoint-sets.testes USING: tools.test disjoint-sets namespaces slots.private ; +IN: disjoint-sets.testes SYMBOL: +blah+ -405534154 +blah+ 1 set-slot diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 80ab2f58bf..05df13f073 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -30,7 +30,7 @@ TUPLE: disjoint-set ranks>> at ; inline : inc-rank ( a disjoint-set -- ) - ranks>> [ 1+ ] change-at ; inline + ranks>> [ 1 + ] change-at ; inline : representative? ( a disjoint-set -- ? ) dupd parent = ; inline diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor index 9f7f25c56e..41d93c889e 100644 --- a/basis/documents/documents-tests.factor +++ b/basis/documents/documents-tests.factor @@ -1,6 +1,6 @@ -IN: documents.tests USING: documents documents.private accessors sequences namespaces tools.test make arrays kernel fry ; +IN: documents.tests ! Tests diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index cc2466053b..b05c86c365 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -45,7 +45,7 @@ TUPLE: document < model locs undos redos inside-undo? ; [ drop ] [ doc-line length ] 2bi 2array ; : doc-lines ( from to document -- slice ) - [ 1+ ] [ value>> ] bi* ; + [ 1 + ] [ value>> ] bi* ; : start-on-line ( from line# document -- n1 ) drop over first = @@ -67,7 +67,7 @@ TUPLE: document < model locs undos redos inside-undo? ; [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ; : last-line# ( document -- line ) - value>> length 1- ; + value>> length 1 - ; CONSTANT: doc-start { 0 0 } @@ -84,7 +84,7 @@ CONSTANT: doc-start { 0 0 } over length 1 = [ nip first2 ] [ - first swap length 1- + 0 + first swap length 1 - + 0 ] if ] dip last length + 2array ; @@ -92,7 +92,7 @@ CONSTANT: doc-start { 0 0 } 0 swap [ append ] change-nth ; : append-last ( str seq -- ) - [ length 1- ] keep [ prepend ] change-nth ; + [ length 1 - ] keep [ prepend ] change-nth ; : loc-col/str ( loc document -- str col ) [ first2 swap ] dip nth swap ; @@ -103,7 +103,7 @@ CONSTANT: doc-start { 0 0 } : (set-doc-range) ( doc-lines from to lines -- changed-lines ) [ prepare-insert ] 3keep - [ [ first ] bi@ 1+ ] dip + [ [ first ] bi@ 1 + ] dip replace-slice ; : entire-doc ( document -- start end document ) diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index 0776f8f158..7ba3cb8a6e 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -23,14 +23,14 @@ SINGLETON: char-elt : prev ( loc document quot: ( loc document -- loc ) -- loc ) { { [ pick { 0 0 } = ] [ 2drop ] } - { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] } + { [ pick second zero? ] [ drop [ first 1 - ] dip line-end ] } [ call ] } cond ; inline : next ( loc document quot: ( loc document -- loc ) -- loc ) { { [ 2over doc-end = ] [ 2drop ] } - { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] } + { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] } [ call ] } cond ; inline @@ -73,7 +73,7 @@ SINGLETON: one-word-elt M: one-word-elt prev-elt drop - [ [ 1- ] dip f prev-word ] modify-col ; + [ [ 1 - ] dip f prev-word ] modify-col ; M: one-word-elt next-elt drop @@ -90,7 +90,7 @@ SINGLETON: word-elt M: word-elt prev-elt drop - [ [ [ 1- ] dip blank-at? prev-word ] modify-col ] + [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ] prev ; M: word-elt next-elt diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor index 30611ca699..43fd679e3a 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -5,8 +5,10 @@ IN: editors ARTICLE: "editor" "Editor integration" "Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment." { $subsection edit } -"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:" +"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ":" { $code "USE: editors.emacs" } +"If you intend to always use the same editor, it helps to have it load during stage 2 bootstrap. Place the code to load and possibly configure it in the " { $link "factor-boot-rc" } "." +$nl "Editor integration vocabularies store a quotation in a global variable when loaded:" { $subsection edit-hook } "If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:" diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index da6a589031..4a6dd9b5be 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -47,43 +47,12 @@ M: cannot-find-source error. : edit-vocab ( name -- ) >vocab-link edit ; -GENERIC: error-file ( error -- file ) - -GENERIC: error-line ( error -- line ) - -M: lexer-error error-file - error>> error-file ; - -M: lexer-error error-line - [ error>> error-line ] [ line>> ] bi or ; - -M: source-file-error error-file - [ error>> error-file ] [ file>> ] bi or ; - -M: source-file-error error-line - error>> error-line ; - -M: condition error-file - error>> error-file ; - -M: condition error-line - error>> error-line ; - -M: object error-file - drop f ; - -M: object error-line - drop f ; - -: (:edit) ( error -- ) +: edit-error ( error -- ) [ error-file ] [ error-line ] bi 2dup and [ edit-location ] [ 2drop ] if ; : :edit ( -- ) - error get (:edit) ; - -: edit-error ( error -- ) - [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ; + error get edit-error ; : edit-each ( seq -- ) [ diff --git a/basis/editors/gvim/gvim-docs.factor b/basis/editors/gvim/gvim-docs.factor new file mode 100644 index 0000000000..fb8682b944 --- /dev/null +++ b/basis/editors/gvim/gvim-docs.factor @@ -0,0 +1,3 @@ +USING: help.syntax ; +IN: editors.gvim +ABOUT: { "vim" "vim" } diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor index c178207e49..6dcf724e8e 100644 --- a/basis/editors/macvim/macvim.factor +++ b/basis/editors/macvim/macvim.factor @@ -1,6 +1,5 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; - IN: editors.macvim : macvim ( file line -- ) diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 65395bd590..561beee4e3 100644 --- a/basis/editors/textmate/textmate.factor +++ b/basis/editors/textmate/textmate.factor @@ -6,4 +6,4 @@ IN: editors.textmate [ "mate" , "-a" , "-l" , number>string , , ] { } make run-detached drop ; -[ textmate ] edit-hook set-global +[ textmate ] edit-hook set-global \ No newline at end of file diff --git a/basis/editors/vim/vim-docs.factor b/basis/editors/vim/vim-docs.factor index 1ec3a37061..522ac826de 100644 --- a/basis/editors/vim/vim-docs.factor +++ b/basis/editors/vim/vim-docs.factor @@ -1,17 +1,18 @@ -USING: definitions editors help help.markup help.syntax io io.files - io.pathnames words ; +USING: definitions editors help help.markup help.syntax +io io.files io.pathnames words ; IN: editors.vim +ABOUT: { "vim" "vim" } + ARTICLE: { "vim" "vim" } "Vim support" -"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." +"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } "." $nl -"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":" -{ $code -"USING: modules namespaces ;" -"REQUIRES: libs/vim ;" -"USE: vim" -"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global" +"The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"vim\"" } ". Which is not very useful, as it starts vim in the same terminal where you started factor." +{ $list + { "If you want to use gvim instead or are on a Windows platform use " { $vocab-link "editors.gvim" } "." } + { "If you want to start vim in an extra terminal, use something like this:" { $code "{ \"urxvt\" \"-e\" \"vim\" } vim-path set-global" } "Replace " { $snippet "urxvt" } " by your terminal of choice." } } -"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." $nl -"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "." ; +"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "." +{ $see-also "editor" } +; diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor index 88c8b8051e..a62ed9e0a5 100644 --- a/basis/editors/vim/vim.factor +++ b/basis/editors/vim/vim.factor @@ -1,6 +1,6 @@ USING: definitions io io.launcher kernel math math.parser namespaces parser prettyprint sequences editors accessors -make ; +make strings ; IN: editors.vim SYMBOL: vim-path @@ -11,7 +11,7 @@ SINGLETON: vim M: vim vim-command [ - vim-path get , + vim-path get dup string? [ , ] [ % ] if [ , ] [ number>string "+" prepend , ] bi* ] { } make ; diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index d27e661193..09c7533b28 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,5 +1,5 @@ -IN: eval.tests USING: eval tools.test ; +IN: eval.tests [ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test [ "USE: math 2 2 +" eval( -- ) ] must-fail diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4acd1eeab8..2a1ac85de0 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -50,7 +50,7 @@ DEFER: (parse-paragraph) parse-paragraph paragraph boa ; : cut-half-slice ( string i -- before after-slice ) - [ head ] [ 1+ short tail-slice ] 2bi ; + [ head ] [ 1 + short tail-slice ] 2bi ; : find-cut ( string quot -- before after delimiter ) dupd find diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index c56372f023..5710ceb985 100644 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - USING: calendar kernel formatting tools.test ; - IN: formatting.tests [ "%s" printf ] must-infer diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index f8b9ba501b..1b1bc8c2af 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - USING: accessors arrays assocs calendar combinators fry kernel generalizations io io.streams.string macros math math.functions math.parser peg.ebnf quotations sequences splitting strings unicode.categories unicode.case vectors combinators.smart ; - IN: formatting exp ( x -- exp base ) [ abs 0 swap [ dup [ 10.0 >= ] [ 1.0 < ] bi or ] [ dup 10.0 >= - [ 10.0 / [ 1+ ] dip ] - [ 10.0 * [ 1- ] dip ] if + [ 10.0 / [ 1 + ] dip ] + [ 10.0 * [ 1 - ] dip ] if ] while ] keep 0 < [ neg ] when ; diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 88ecae66ad..549db25e09 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,6 +1,6 @@ -IN: fry.tests USING: fry tools.test math prettyprint kernel io arrays sequences eval accessors ; +IN: fry.tests [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index d50fd9442b..fd029cc329 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -26,7 +26,7 @@ M: >r/r>-in-fry-error summary : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect - empty? [ >r/r>-in-fry-error ] unless ; + [ >r/r>-in-fry-error ] unless-empty ; PREDICATE: fry-specifier < word { _ @ } memq? ; @@ -42,7 +42,7 @@ GENERIC: deep-fry ( obj -- ) check-fry [ [ deep-fry ] each ] [ ] make [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat - { _ } split [ spread>quot ] [ length 1- ] bi ; + { _ } split [ spread>quot ] [ length 1 - ] bi ; PRIVATE> diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 03bd21e58c..a21313312b 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,6 +1,6 @@ -IN: functors.tests USING: functors tools.test math words kernel multiline parser io.streams.string generic ; +IN: functors.tests << diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5129515980..5f519aeece 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.mixin classes.parser classes.singleton -classes.tuple classes.tuple.parser combinators effects effects.parser -fry generic generic.parser generic.standard interpolate -io.streams.string kernel lexer locals.parser locals.rewrite.closures -locals.types make namespaces parser quotations sequences vocabs.parser -words words.symbol ; +USING: accessors arrays classes.mixin classes.parser +classes.singleton classes.tuple classes.tuple.parser +combinators effects.parser fry generic generic.parser +generic.standard interpolate io.streams.string kernel lexer +locals.parser locals.types macros make namespaces parser +quotations sequences vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -117,6 +117,11 @@ SYNTAX: `GENERIC: complete-effect parsed \ define-simple-generic* parsed ; +SYNTAX: `MACRO: + scan-param parsed + parse-declared* + \ define-macro parsed ; + SYNTAX: `inline [ word make-inline ] over push-all ; SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; @@ -152,6 +157,7 @@ DEFER: ;FUNCTOR delimiter { "SYNTAX:" POSTPONE: `SYNTAX: } { "SYMBOL:" POSTPONE: `SYMBOL: } { "inline" POSTPONE: `inline } + { "MACRO:" POSTPONE: `MACRO: } { "call-next-method" POSTPONE: `call-next-method } } ; diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 83ed00ca1b..6468b8deb7 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -33,18 +33,6 @@ HELP: new-action HELP: page-action { $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ; -HELP: param -{ $values - { "name" string } - { "value" string } -} -{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } -{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; - -HELP: params -{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." } -{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; - HELP: validate-integer-id { $description "A utility word which validates an integer parameter named " { $snippet "id" } "." } { $examples @@ -103,7 +91,7 @@ $nl ARTICLE: "furnace.actions.config" "Furnace action configuration" "Actions have the following slots:" { $table - { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } } + { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error. A more general facility can be found in the " { $vocab-link "http.server.rewrite" } " vocabulary." } } { { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } } { { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } } { { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } } @@ -144,10 +132,8 @@ ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle" "Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ; ARTICLE: "furnace.actions.impl" "Furnace actions implementation" -"The following words are used by the action implementation and there is rarely any reason to call them directly:" -{ $subsection new-action } -{ $subsection param } -{ $subsection params } ; +"The following parametrized constructor should be called from constructors for subclasses of " { $link action } ":" +{ $subsection new-action } ; ARTICLE: "furnace.actions" "Furnace actions" "The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle." diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 06e743e967..aca03b9029 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -17,8 +17,6 @@ html.templates.chloe.syntax html.templates.chloe.compiler ; IN: furnace.actions -SYMBOL: params - SYMBOL: rest TUPLE: action rest init authorize display validate submit ; @@ -60,9 +58,6 @@ TUPLE: action rest init authorize display validate submit ; ] [ drop <400> ] if ] with-exit-continuation ; -: param ( name -- value ) - params get at ; - CONSTANT: revalidate-url-key "__u" : revalidate-url ( -- url/f ) @@ -88,13 +83,12 @@ CONSTANT: revalidate-url-key "__u" ] [ drop <400> ] if ] with-exit-continuation ; -: handle-rest ( path action -- assoc ) - rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; +: handle-rest ( path action -- ) + rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ; : init-action ( path action -- ) begin-form - handle-rest - request get request-params assoc-union params set ; + handle-rest ; M: action call-responder* ( path action -- response ) [ init-action ] keep diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor deleted file mode 100644 index 54c32e7b4a..0000000000 --- a/basis/furnace/auth/auth-tests.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: furnace.auth tools.test ; -IN: furnace.auth.tests - diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor deleted file mode 100644 index 996047e83d..0000000000 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.edit-profile.tests -USING: tools.test furnace.auth.features.edit-profile ; - - diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor deleted file mode 100644 index 313b8ef397..0000000000 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.recover-password -USING: tools.test furnace.auth.features.recover-password ; - - diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor deleted file mode 100644 index 42acda416c..0000000000 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.registration.tests -USING: tools.test furnace.auth.features.registration ; - - diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor deleted file mode 100644 index aabd0c5c30..0000000000 --- a/basis/furnace/auth/login/login-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.login.tests -USING: tools.test furnace.auth.login ; - - diff --git a/basis/furnace/auth/login/permits/permits.factor b/basis/furnace/auth/login/permits/permits.factor index 1a9784f147..c6a037cea1 100644 --- a/basis/furnace/auth/login/permits/permits.factor +++ b/basis/furnace/auth/login/permits/permits.factor @@ -1,6 +1,5 @@ USING: accessors namespaces kernel combinators.short-circuit db.tuples db.types furnace.auth furnace.sessions furnace.cache ; - IN: furnace.auth.login.permits TUPLE: permit < server-state session uid ; diff --git a/basis/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor index 8fe1dd4dd4..44a20e7ae3 100644 --- a/basis/furnace/auth/providers/assoc/assoc-tests.factor +++ b/basis/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,7 +1,7 @@ -IN: furnace.auth.providers.assoc.tests USING: furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; +IN: furnace.auth.providers.assoc.tests "Test" >>users diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor index f5a79d701b..a7a48307c9 100644 --- a/basis/furnace/auth/providers/assoc/assoc.factor +++ b/basis/furnace/auth/providers/assoc/assoc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: furnace.auth.providers.assoc USING: accessors assocs kernel furnace.auth.providers ; +IN: furnace.auth.providers.assoc TUPLE: users-in-memory assoc ; diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor index de7650d9ef..f23a4a8527 100644 --- a/basis/furnace/auth/providers/db/db-tests.factor +++ b/basis/furnace/auth/providers/db/db-tests.factor @@ -1,4 +1,3 @@ -IN: furnace.auth.providers.db.tests USING: furnace.actions furnace.auth furnace.auth.login @@ -6,6 +5,7 @@ furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files io.files.temp io.directories accessors kernel ; +IN: furnace.auth.providers.db.tests "test" realm set diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor deleted file mode 100644 index 15698d8e9b..0000000000 --- a/basis/furnace/db/db-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.db.tests -USING: tools.test furnace.db ; - - diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index 1d5aa43c7b..6fe2633031 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,8 @@ -IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel namespaces accessors io.streams.string urls xml.writer ; +IN: furnace.tests + TUPLE: funny-dispatcher < dispatcher ; : ( -- dispatcher ) funny-dispatcher new-dispatcher ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 99855c76fa..49311ee891 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -1,10 +1,10 @@ -IN: furnace.sessions.tests USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses math namespaces make kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files io.files.temp io.directories splitting destructors sequences db db.tuples db.sqlite continuations urls math.parser furnace furnace.utilities ; +IN: furnace.sessions.tests : with-session ( session quot -- ) [ @@ -19,7 +19,7 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop - "x" [ 1+ ] schange + "x" [ 1 + ] schange "x" sget number>string "text/html" ; : url-responder-mock-test ( -- string ) @@ -53,7 +53,7 @@ M: foo call-responder* "auth-test.db" temp-file [ - init-request + "GET" >>method init-request session ensure-table "127.0.0.1" 1234 remote-address set @@ -73,7 +73,7 @@ M: foo call-responder* [ 9 ] [ "x" sget sq ] unit-test - [ ] [ "x" [ 1- ] schange ] unit-test + [ ] [ "x" [ 1 - ] schange ] unit-test [ 4 ] [ "x" sget sq ] unit-test diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index e7fdaf64d6..b00f7fa523 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -63,10 +63,6 @@ HELP: referrer { $values { "referrer/f" { $maybe string } } } { $description "Outputs the current request's referrer URL." } ; -HELP: request-params -{ $values { "request" request } { "assoc" assoc } } -{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; - HELP: resolve-base-path { $values { "string" string } { "string'" string } } { $description "Resolves a responder-relative URL." } ; @@ -121,6 +117,5 @@ ARTICLE: "furnace.misc" "Miscellaneous Furnace features" { $subsection exit-with } "Other useful words:" { $subsection hidden-form-field } -{ $subsection request-params } { $subsection client-state } { $subsection user-agent } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index a43466489c..dc90ad4e8c 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -91,13 +91,6 @@ M: object modify-form drop f ; CONSTANT: nested-forms-key "__n" -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ url>> query>> ] } - { "HEAD" [ url>> query>> ] } - { "POST" [ post-data>> params>> ] } - } case ; - : referrer ( -- referrer/f ) #! Typo is intentional, it's in the HTTP spec! "referer" request get header>> at diff --git a/basis/game-input/game-input-tests.factor b/basis/game-input/game-input-tests.factor index 3cce0da575..10f3b5d7f5 100644 --- a/basis/game-input/game-input-tests.factor +++ b/basis/game-input/game-input-tests.factor @@ -1,8 +1,9 @@ +USING: ui game-input tools.test kernel system threads calendar +combinators.short-circuit ; IN: game-input.tests -USING: ui game-input tools.test kernel system threads calendar ; -os windows? os macosx? or [ +os { [ windows? ] [ macosx? ] } 1|| [ [ ] [ open-game-input ] unit-test [ ] [ 1 seconds sleep ] unit-test [ ] [ close-game-input ] unit-test -] when \ No newline at end of file +] when diff --git a/basis/game-input/game-input.factor b/basis/game-input/game-input.factor index 922906df48..c21b900d8c 100755 --- a/basis/game-input/game-input.factor +++ b/basis/game-input/game-input.factor @@ -45,12 +45,12 @@ ERROR: game-input-not-open ; game-input-opened? [ (open-game-input) ] unless - game-input-opened [ 1+ ] change-global + game-input-opened [ 1 + ] change-global reset-mouse ; : close-game-input ( -- ) game-input-opened [ dup zero? [ game-input-not-open ] when - 1- + 1 - ] change-global game-input-opened? [ (close-game-input) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 92c0c7173a..71d547ad29 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -153,7 +153,7 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; : record-button ( state hid-value element -- ) - [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ; + [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ; : record-controller ( controller-state value -- ) dup IOHIDValueGetElement { diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index abcbd54cab..e7b3ee8252 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -24,20 +24,20 @@ MACRO: narray ( n -- ) '[ _ { } nsequence ] ; MACRO: nsum ( n -- ) - 1- [ + ] n*quot ; + 1 - [ + ] n*quot ; MACRO: firstn-unsafe ( n -- ) [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ 1- swap bounds-check 2drop ] + [ 1 - swap bounds-check 2drop ] [ firstn-unsafe ] bi-curry '[ _ _ bi ] ] if ; MACRO: npick ( n -- ) - 1- [ dup ] [ '[ _ dip swap ] ] repeat ; + 1 - [ dup ] [ '[ _ dip swap ] ] repeat ; MACRO: nover ( n -- ) dup 1 + '[ _ npick ] n*quot ; @@ -46,10 +46,10 @@ MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; MACRO: nrot ( n -- ) - 1- [ ] [ '[ _ dip swap ] ] repeat ; + 1 - [ ] [ '[ _ dip swap ] ] repeat ; MACRO: -nrot ( n -- ) - 1- [ ] [ '[ swap _ dip ] ] repeat ; + 1 - [ ] [ '[ swap _ dip ] ] repeat ; MACRO: ndrop ( n -- ) [ drop ] n*quot ; @@ -91,7 +91,7 @@ MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + 1 + '[ _ -nrot ] swap '[ _ _ napply ] ; MACRO: nweave ( n -- ) [ dup [ '[ _ _ mnswap ] ] with map ] keep diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor index 45eb27ea62..bdc0623d54 100644 --- a/basis/globs/globs-tests.factor +++ b/basis/globs/globs-tests.factor @@ -1,5 +1,5 @@ -IN: globs.tests USING: tools.test globs ; +IN: globs.tests [ f ] [ "abd" "fdf" glob-matches? ] unit-test [ f ] [ "fdsafas" "?" glob-matches? ] unit-test diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 50ffa65474..07250058ae 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -17,10 +17,16 @@ ARTICLE: "grouping" "Groups and clumps" "The difference can be summarized as the following:" { $list { "With groups, the subsequences form the original sequence when concatenated:" - { $unchecked-example "dup n groups concat sequence= ." "t" } + { $unchecked-example + "USING: grouping ;" + "{ 1 2 3 4 } dup" "2 concat sequence= ." "t" + } } { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:" - { $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" } + { $unchecked-example + "USING: grouping ;" + "{ 1 2 3 4 } dup" "2 unclip-last [ [ first ] map ] dip append sequence= ." "t" + } } } "A combinator built using clumps:" diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index ec13e3a750..f68760a4e1 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -35,7 +35,7 @@ M: slice-chunking nth-unsafe group@ slice boa ; TUPLE: abstract-groups < chunking-seq ; M: abstract-groups length - [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ; + [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; M: abstract-groups set-length [ n>> * ] [ seq>> ] bi set-length ; @@ -46,10 +46,10 @@ M: abstract-groups group@ TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1+ ; + [ seq>> length ] [ n>> ] bi - 1 + ; M: abstract-clumps set-length - [ n>> + 1- ] [ seq>> ] bi set-length ; + [ n>> + 1 - ] [ seq>> ] bi set-length ; M: abstract-clumps group@ [ n>> over + ] [ seq>> ] bi ; @@ -100,4 +100,4 @@ INSTANCE: sliced-clumps slice-chunking : all-equal? ( seq -- ? ) [ = ] monotonic? ; -: all-eq? ( seq -- ? ) [ eq? ] monotonic? ; \ No newline at end of file +: all-eq? ( seq -- ? ) [ eq? ] monotonic? ; diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index b476107562..c1985c516f 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -52,7 +52,7 @@ IN: heaps.tests ] each : sort-entries ( entries -- entries' ) - [ [ key>> ] compare ] sort ; + [ key>> ] sort-with ; : delete-test ( n -- obj1 obj2 ) [ diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 32ed10d8f2..677daca69d 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -46,7 +46,7 @@ M: heap heap-size ( heap -- n ) : right ( n -- m ) 1 shift 2 + ; inline -: up ( n -- m ) 1- 2/ ; inline +: up ( n -- m ) 1 - 2/ ; inline : data-nth ( n heap -- entry ) data>> nth-unsafe ; inline @@ -164,7 +164,7 @@ M: bad-heap-delete summary M: heap heap-delete ( entry heap -- ) [ entry>index ] keep - 2dup heap-size 1- = [ + 2dup heap-size 1 - = [ nip data-pop* ] [ [ nip data-pop ] 2keep diff --git a/basis/help/apropos/apropos-tests.factor b/basis/help/apropos/apropos-tests.factor index 3dbda475de..6fa4217522 100644 --- a/basis/help/apropos/apropos-tests.factor +++ b/basis/help/apropos/apropos-tests.factor @@ -1,4 +1,4 @@ -IN: help.apropos.tests USING: help.apropos tools.test ; +IN: help.apropos.tests [ ] [ "swp" apropos ] unit-test diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index ff385f9a65..6bf88f8f03 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -45,7 +45,7 @@ ARTICLE: "cookbook-colon-defs" "Shuffle word and definition cookbook" { $code ": sq ( x -- y ) dup * ;" } "(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)" $nl -"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." } +"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word and a stack effect declaration must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." } $nl "Factor is all about code reuse through short and logical colon definitions. Breaking up a problem into small pieces which are easy to test is called " { $emphasis "factoring." } $nl @@ -154,11 +154,11 @@ $nl } "Note that words must be defined before being referenced. The following is generally invalid:" { $code - ": frob accelerate particles ;" - ": accelerate accelerator on ;" - ": particles [ (particles) ] each ;" + ": frob ( what -- ) accelerate particles ;" + ": accelerate ( -- ) accelerator on ;" + ": particles ( what -- ) [ (particles) ] each ;" } -"You would have to place the first definition after the two others for the parser to accept the file." +"You would have to place the first definition after the two others for the parser to accept the file. If you have a set of mutually recursive words, you can use " { $link POSTPONE: DEFER: } "." { $references { } "word-search" @@ -277,7 +277,7 @@ $nl "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast." { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." } } -"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." +"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such as manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; @@ -287,6 +287,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" "Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM." "Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail." { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } + { "Also, " { $link dup } " and related shuffle words don't copy entire objects or arrays; they only duplicate the reference to them. If you want to guard an object against mutation, use " { $link clone } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 95d4612cbe..4022d3bd38 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -1,7 +1,7 @@ -IN: help.crossref.tests USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; +IN: help.crossref.tests [ ] [ "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- ) diff --git a/basis/help/handbook/handbook-tests.factor b/basis/help/handbook/handbook-tests.factor index 240ce67240..709d56c5d6 100644 --- a/basis/help/handbook/handbook-tests.factor +++ b/basis/help/handbook/handbook-tests.factor @@ -1,5 +1,5 @@ -IN: help.handbook.tests USING: help tools.test ; +IN: help.handbook.tests [ ] [ "article-index" print-topic ] unit-test [ ] [ "primitive-index" print-topic ] unit-test diff --git a/basis/help/help-tests.factor b/basis/help/help-tests.factor index e091278359..d8c5a32f3d 100644 --- a/basis/help/help-tests.factor +++ b/basis/help/help-tests.factor @@ -1,6 +1,6 @@ -IN: help.tests USING: tools.test help kernel ; +IN: help.tests [ 3 throw ] must-fail [ ] [ :help ] unit-test -[ ] [ f print-topic ] unit-test \ No newline at end of file +[ ] [ f print-topic ] unit-test diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 3ba336be0b..90ff6c110f 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,6 +1,6 @@ -IN: help.html.tests USING: help.html tools.test help.topics kernel ; +IN: help.html.tests [ ] [ "xml" >link help>html drop ] unit-test -[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test \ No newline at end of file +[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 84f708a687..e8cc7e04c5 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -73,7 +73,7 @@ M: topic url-of topic>filename ; dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) - all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ; + all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ; : all-topics ( -- topics ) [ @@ -115,7 +115,7 @@ TUPLE: result title href ; load-index swap >lower '[ [ drop _ ] dip >lower subseq? ] assoc-filter [ swap result boa ] { } assoc>map - [ [ title>> ] compare ] sort ; + [ title>> ] sort-with ; : article-apropos ( string -- results ) "articles.idx" offline-apropos ; diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index a46e577357..7df196a79f 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -11,25 +11,30 @@ $nl { $code "USE: tools.scaffold" } "Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":" { $code "\"resource:work\" \"palindrome\" scaffold-vocab" } -"If you look at the output, you will see that a few files were created in your “work” directory. The following phrase will print the full path of your work directory:" +"If you look at the output, you will see that a few files were created in your “work” directory, and that the new source file was loaded." +$nl +"The following phrase will print the full path of your work directory:" { $code "\"work\" resource-path ." } "The work directory is one of several " { $link "vocabs.roots" } " where Factor searches for vocabularies. It is possible to define new vocabulary roots; see " { $link "add-vocab-roots" } ". To keep things simple in this tutorial, we'll just use the work directory, though." $nl -"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file." -$nl -"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" -{ $code "IN: palindrome" } -"We will add new definitions after the " { $link POSTPONE: IN: } " form." +"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". Open this file in your text editor." $nl "You are now ready to go on to the next section: " { $link "first-program-logic" } "." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" { $code - "! Copyright (C) 2008 " + "! Copyright (C) 2009 " "! See http://factorcode.org/license.txt for BSD license." + "USING: ;" "IN: palindrome" } +"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word. We will add new definitions after the " { $link POSTPONE: IN: } " form." +$nl +"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:" +{ $code "USE: palindrome" } +"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:" +{ $code "\"palindrome\" reload" } "We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "." $nl "Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:" @@ -42,7 +47,7 @@ $nl $nl "To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary." $nl -"So now, add the following at the start of the source file:" +"Go back to the third line in your source file and change it to:" { $code "USING: kernel ;" } "Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the listener's input area, and press " { $operation com-browse } "." $nl @@ -55,15 +60,15 @@ $nl ARTICLE: "first-program-test" "Testing your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" { $code - "! Copyright (C) 2008 " + "! Copyright (C) 2009 " "! See http://factorcode.org/license.txt for BSD license." - "IN: palindrome" "USING: kernel sequences ;" + "IN: palindrome" "" ": palindrome? ( str -- ? ) dup reverse = ;" } -"We will now test our new word in the listener. First we have add the palindrome vocabulary to the listener's vocabulary search path:" -{ $code "USE: palindrome"} +"We will now test our new word in the listener. If you haven't done so already, add the palindrome vocabulary to the listener's vocabulary search path:" +{ $code "USE: palindrome" } "Next, push a string on the stack:" { $code "\"hello\"" } "Note that the stack display in the listener now shows this string. Having supplied the input, we call our word:" @@ -82,9 +87,8 @@ $nl $nl "We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values." $nl -"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":" +"Add the following two lines to " { $snippet "palindrome-tests.factor" } ":" { $code - "USING: palindrome tools.test ;" "[ f ] [ \"hello\" palindrome? ] unit-test" "[ t ] [ \"racecar\" palindrome? ] unit-test" } @@ -105,7 +109,7 @@ $nl { $code "\"palindrome\" test" } "The next step is to, of course, fix our code so that the unit test can pass." $nl -"We begin by writing a word called " { $snippet "normalize" } " which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener." +"We begin by writing a word which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener." $nl "Start by pushing a character on the stack; notice that characters are really just integers:" { $code "CHAR: a" } @@ -132,7 +136,7 @@ $nl { $code "[ Letter? ] filter >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" { $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" } -"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." +"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link >lower } " and " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" } diff --git a/basis/help/vocabs/vocabs-tests.factor b/basis/help/vocabs/vocabs-tests.factor index f03e0b3337..5637dd92f4 100644 --- a/basis/help/vocabs/vocabs-tests.factor +++ b/basis/help/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ -IN: help.vocabs.tests USING: help.vocabs tools.test help.markup help vocabs ; +IN: help.vocabs.tests [ ] [ { $vocab "scratchpad" } print-content ] unit-test -[ ] [ "classes" vocab print-topic ] unit-test \ No newline at end of file +[ ] [ "classes" vocab print-topic ] unit-test diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d10bd5f8a9..6b7a6ae8ca 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -69,7 +69,7 @@ t specialize-method? set-global dup [ array? ] all? [ first ] when length ; SYNTAX: HINTS: - scan-object + scan-object dup wrapper? [ wrapped>> ] when [ changed-definition ] [ parse-definition { } like "specializer" set-word-prop ] bi ; diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index c901e35e3e..d1d43c762c 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -1,9 +1,9 @@ -IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; FROM: html.components => inspector ; +IN: html.components.tests [ ] [ begin-form ] unit-test diff --git a/basis/html/forms/forms-tests.factor b/basis/html/forms/forms-tests.factor index 006a435cf0..b1596e9aa6 100644 --- a/basis/html/forms/forms-tests.factor +++ b/basis/html/forms/forms-tests.factor @@ -1,7 +1,7 @@ -IN: html.forms.tests USING: kernel sequences tools.test assocs html.forms validators accessors namespaces ; FROM: html.forms => values ; +IN: html.forms.tests : with-validation ( quot -- messages ) [ diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index cc8b4f0a15..5cf318bcaf 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -44,7 +44,7 @@ M: form clone [ value ] dip '[ [ form [ clone ] change - 1+ "index" set-value + 1 + "index" set-value "value" set-value @ ] with-scope @@ -54,7 +54,7 @@ M: form clone [ value ] dip '[ [ begin-form - 1+ "index" set-value + 1 + "index" set-value from-object @ ] with-scope diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index ceb2e72478..a98a21f177 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -17,7 +17,7 @@ TUPLE: template-lexer < lexer ; M: template-lexer skip-word [ { - { [ 2dup nth CHAR: " = ] [ drop 1+ ] } + { [ 2dup nth CHAR: " = ] [ drop 1 + ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } [ f skip ] } cond diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index c391b417a9..7a7fcffc74 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,5 +1,6 @@ USING: http.client http.client.private http tools.test namespaces urls ; +IN: http.client.tests [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/client/post-data/post-data-tests.factor b/basis/http/client/post-data/post-data-tests.factor deleted file mode 100644 index 2704ce169f..0000000000 --- a/basis/http/client/post-data/post-data-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test http.client.post-data ; -IN: http.client.post-data.tests diff --git a/basis/http/parsers/parsers-tests.factor b/basis/http/parsers/parsers-tests.factor index f87ed47f00..f8c3b836a6 100644 --- a/basis/http/parsers/parsers-tests.factor +++ b/basis/http/parsers/parsers-tests.factor @@ -1,5 +1,5 @@ -IN: http.parsers.tests USING: http http.parsers tools.test ; +IN: http.parsers.tests [ { } ] [ "" parse-cookie ] unit-test [ { } ] [ "" parse-set-cookie ] unit-test @@ -13,4 +13,4 @@ unit-test [ { T{ cookie { name "__s" } { value "12345567" } } } ] [ "__s=12345567;" parse-cookie ] -unit-test \ No newline at end of file +unit-test diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 72ff111db9..d502de75b0 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -1,6 +1,6 @@ -IN: http.server.redirection.tests USING: http http.server.redirection urls accessors namespaces tools.test present kernel ; +IN: http.server.redirection.tests [ diff --git a/basis/http/server/rewrite/rewrite-docs.factor b/basis/http/server/rewrite/rewrite-docs.factor new file mode 100644 index 0000000000..9ded10bded --- /dev/null +++ b/basis/http/server/rewrite/rewrite-docs.factor @@ -0,0 +1,72 @@ +IN: http.server.rewrite +USING: help.syntax help.markup http.server ; + +HELP: rewrite +{ $class-description "The class of directory rewrite responders. The slots are as follows:" +{ $list + { { $slot "default" } " - the responder to call if no file name is provided." } + { { $slot "child" } " - the responder to call if a file name is provided." } + { { $slot "param" } " - the name of a request parameter which will store the first path component of the file name passed to the responder." } +} } ; + +HELP: +{ $values { "rewrite" rewrite } } +{ $description "Creates a new " { $link rewrite } " responder." } +{ $examples + { $code + "" + " >>default" + " >>child" + " \"comment_id\" >>param" + } +} ; + +HELP: vhost-rewrite +{ $class-description "The class of virtual host rewrite responders. The slots are as follows:" +{ $list + { { $slot "default" } " - the responder to call if no host name prefix is provided." } + { { $slot "child" } " - the responder to call if a host name prefix is provided." } + { { $slot "param" } " - the name of a request parameter which will store the first host name component of the host name passed to the responder." } + { { $slot "suffix" } " - the domain name suffix which will be chopped off the end of the request's host name in order to produce the parameter." } +} } ; + +HELP: +{ $values { "vhost-rewrite" vhost-rewrite } } +{ $description "Creates a new " { $link vhost-rewrite } " responder." } +{ $examples + { $code + "" + " >>default" + " >>child" + " \"blog_id\" >>param" + " \"blogs.vegan.net\" >>suffix" + } +} ; + +ARTICLE: "http.server.rewrite.overview" "Rewrite responder overview" +"Rewrite responders take the file name and turn it into a request parameter named by the " { $slot "param" } " slot before delegating to a child responder. If a file name is provided, it calls the responder in the " { $slot "child" } " slot. If no file name is provided, they call the default responder in the " { $slot "default" } " slot." +$nl +"For example, suppose you want to have the following website schema:" +{ $list +{ { $snippet "/posts/" } " - show a list of posts" } +{ { $snippet "/posts/factor_language" } " - show thread with ID " { $snippet "factor_language" } } +{ { $snippet "/posts/factor_language/1" } " - show first comment in the thread with ID " { $snippet "factor_language" } } +{ { $snippet "/animals" } ", ... - a bunch of other actions" } } +"One way to achieve this would be to have a nesting of responders as follows:" +{ $list +{ "A dispatcher at the top level" } + { "A " { $link rewrite } " as a child of the dispatcher under the name " { $snippet "posts" } ". The rewrite has the " { $slot "param" } " slot set to, say, " { $snippet "post_id" } ". The " { $slot "default" } " slot is set to a Furnace action which displays a list of posts." } + { "The child slot is set to a second " { $link rewrite } " instance, with " { $snippet "param" } " set to " { $snippet "comment_id" } ", the " { $slot "default" } " slot set to an action which displays a post identified by the " { $snippet "post_id" } " parameter, and the " { $snippet "child" } " slot set to an action which displays the comment identified by the " { $snippet "comment_id" } " parameter." } } +"Note that parameters can be extracted from the request using the " { $link param } " word, but most of the time you want to use " { $vocab-link "furnace.actions" } " instead." ; + +ARTICLE: "http.server.rewrite" "URL rewrite responders" +"The " { $vocab-link "http.server.rewrite" } " vocabulary defines two responder types which can help make website URLs more human-friendly." +{ $subsection "http.server.rewrite.overview" } +"Directory rewrite responders:" +{ $subsection rewrite } +{ $subsection } +"Virtual host rewrite responders -- these chop off the value in the " { $snippet "suffix" } " slot from the tail of the host name, and use the rest as the parameter value:" +{ $subsection vhost-rewrite } +{ $subsection } ; + +ABOUT: "http.server.rewrite" \ No newline at end of file diff --git a/basis/http/server/rewrite/rewrite-tests.factor b/basis/http/server/rewrite/rewrite-tests.factor new file mode 100644 index 0000000000..3a053c3a9c --- /dev/null +++ b/basis/http/server/rewrite/rewrite-tests.factor @@ -0,0 +1,48 @@ +USING: accessors arrays http.server http.server.rewrite kernel +namespaces tools.test urls ; +IN: http.server.rewrite.tests + +TUPLE: rewrite-test-default ; + +M: rewrite-test-default call-responder* + drop "DEFAULT!" 2array ; + +TUPLE: rewrite-test-child ; + +M: rewrite-test-child call-responder* + drop "rewritten-param" param 2array ; + +V{ } clone responder-nesting set +H{ } clone params set + + + rewrite-test-child new >>child + rewrite-test-default new >>default + "rewritten-param" >>param +"rewrite" set + +[ { { } "DEFAULT!" } ] [ { } "rewrite" get call-responder ] unit-test +[ { { } "xxx" } ] [ { "xxx" } "rewrite" get call-responder ] unit-test +[ { { "blah" } "xxx" } ] [ { "xxx" "blah" } "rewrite" get call-responder ] unit-test + + + rewrite-test-child new >>child + rewrite-test-default new >>default + "rewritten-param" >>param + "blogs.vegan.net" >>suffix +"rewrite" set + +[ { { } "DEFAULT!" } ] [ + URL" http://blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test + +[ { { } "DEFAULT!" } ] [ + URL" http://www.blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test + +[ { { } "erg" } ] [ + URL" http://erg.blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test \ No newline at end of file diff --git a/basis/http/server/rewrite/rewrite.factor b/basis/http/server/rewrite/rewrite.factor new file mode 100644 index 0000000000..86c6f83ad5 --- /dev/null +++ b/basis/http/server/rewrite/rewrite.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors http.server http.server.dispatchers kernel +namespaces sequences splitting urls ; +IN: http.server.rewrite + +TUPLE: rewrite param child default ; + +: ( -- rewrite ) + rewrite new ; + +M: rewrite call-responder* + over empty? [ default>> ] [ + [ [ first ] [ param>> ] bi* set-param ] + [ [ rest ] [ child>> ] bi* ] + 2bi + ] if + call-responder* ; + +TUPLE: vhost-rewrite suffix param child default ; + +: ( -- vhost-rewrite ) + vhost-rewrite new ; + +: sub-domain? ( vhost-rewrite url -- subdomain ? ) + swap suffix>> dup [ + [ host>> canonical-host ] [ "." prepend ] bi* ?tail + ] [ 2drop f f ] if ; + +M: vhost-rewrite call-responder* + dup url get sub-domain? + [ over param>> set-param child>> ] [ drop default>> ] if + call-responder ; diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index daf0305972..e6d5c63ac1 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ; +USING: help.markup help.syntax io.streams.string quotations strings urls +http vocabs.refresh math io.servers.connection assocs ; IN: http.server HELP: trivial-responder @@ -52,12 +53,33 @@ HELP: httpd HELP: http-insomniac { $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ; +HELP: request-params +{ $values { "request" request } { "assoc" assoc } } +{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; + +HELP: param +{ $values + { "name" string } + { "value" string } +} +{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ; + +HELP: params +{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ; + ARTICLE: "http.server.requests" "HTTP request variables" "The following variables are set by the HTTP server at the beginning of a request." { $subsection request } { $subsection url } { $subsection post-request? } { $subsection responder-nesting } +{ $subsection params } +"Utility words:" +{ $subsection param } +{ $subsection set-param } +{ $subsection request-params } "Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ; ARTICLE: "http.server.responders" "HTTP server responders" diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 8682c97c73..131fe3fe18 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -3,7 +3,8 @@ USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations combinators vocabs.refresh tools.time math math.parser present -io vectors +vectors hashtables +io io.sockets io.sockets.secure io.encodings @@ -212,8 +213,25 @@ LOG: httpd-header NOTICE : split-path ( string -- path ) "/" split harvest ; +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "POST" [ post-data>> params>> ] } + } case ; + +SYMBOL: params + +: param ( name -- value ) + params get at ; + +: set-param ( value name -- ) + params get set-at ; + : init-request ( request -- ) - [ request set ] [ url>> url set ] bi + [ request set ] + [ url>> url set ] + [ request-params >hashtable params set ] tri V{ } clone responder-nesting set ; : dispatch-request ( request -- response ) diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor index d54be03698..185b0eb361 100644 --- a/basis/http/server/static/static-tests.factor +++ b/basis/http/server/static/static-tests.factor @@ -1,4 +1,4 @@ -IN: http.server.static.tests USING: http.server.static tools.test xml.writer ; +IN: http.server.static.tests -[ ] [ "resource:basis" directory>html write-xml ] unit-test \ No newline at end of file +[ ] [ "resource:basis" directory>html write-xml ] unit-test diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index ca3ea8d2b4..ec7a70b656 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -229,8 +229,8 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; ] with each^2 ; : sign-extend ( bits v -- v' ) - swap [ ] [ 1- 2^ < ] 2bi - [ -1 swap shift 1+ + ] [ drop ] if ; + swap [ ] [ 1 - 2^ < ] 2bi + [ -1 swap shift 1 + + ] [ drop ] if ; : read1-jpeg-dc ( decoder -- dc ) [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; @@ -245,7 +245,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; 0 :> k! [ color ac-huff-table>> read1-jpeg-ac - [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri + [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri { 0 0 } = not k 63 < and ] loop diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 22283deecb..e9130a3c40 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -46,7 +46,7 @@ PRIVATE> array>> [ value ] map ; : ( specification -- map ) - all-intervals [ [ first second ] compare ] sort + all-intervals [ first second ] sort-with >intervals ensure-disjoint interval-map boa ; : ( specification -- map ) @@ -58,7 +58,7 @@ PRIVATE> [ alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip [| oldkey oldval key val | ! Underneath is start - oldkey 1+ key = + oldkey 1 + key = oldval val = and [ oldkey 2array oldval 2array , key ] unless key val diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 51ab6f27d9..571957cf4c 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -21,7 +21,7 @@ C: foo : something ( array -- num ) { - { [ dup 1+ 2array ] [ 3 * ] } + { [ dup 1 + 2array ] [ 3 * ] } { [ 3array ] [ + + ] } } switch ; @@ -92,5 +92,5 @@ TUPLE: funny-tuple ; [ ] [ [ ] [undo] drop ] unit-test -[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test -[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] inputsequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1 + ] bi@ ] inputsequence 2 [ [undo] '[ dup _ assure-same-class _ inputsequence ] ] define-pop-inverse +! conditionals + +:: undo-if-empty ( result a b -- seq ) + a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ; + +:: undo-if* ( result a b -- boolean ) + b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ; + +\ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse + +\ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; @@ -283,4 +295,4 @@ M: no-match summary drop "Fall through in switch" ; reverse [ [ [undo] ] dip compose ] { } assoc>map recover-chain ; -MACRO: switch ( quot-alist -- ) [switch] ; +MACRO: switch ( quot-alist -- ) [switch] ; \ No newline at end of file diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index 7d0acb4140..8022ed34e2 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -40,7 +40,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ; dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; : num-fds ( mx -- n ) - [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; + [ reads>> max-fd ] [ writes>> max-fd ] bi max 1 + ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor index 7237651b80..a66b2aad7a 100755 --- a/basis/io/backend/windows/privileges/privileges-tests.factor +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.windows.privileges.tests USING: io.backend.windows.privileges tools.test ; +IN: io.backend.windows.privileges.tests [ [ ] with-privileges ] must-infer diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 1654cb8b83..16132ca810 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -5,7 +5,7 @@ IN: io.encodings.ascii ] keep + MAX_PATH 1 + [ ] keep "DWORD" "DWORD" "DWORD" - MAX_PATH 1+ [ ] keep + MAX_PATH 1 + [ ] keep [ GetVolumeInformation win32-error=0/f ] 7 nkeep drop 5 nrot drop [ utf16n alien>string ] 4 ndip @@ -165,13 +165,13 @@ M: winnt file-system-info ( path -- file-system-info ) ] if ; : find-first-volume ( -- string handle ) - MAX_PATH 1+ [ ] keep + MAX_PATH 1 + [ ] keep dupd FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; : find-next-volume ( handle -- string/f ) - MAX_PATH 1+ [ tuck ] keep + MAX_PATH 1 + [ tuck ] keep FindNextVolume 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor index 7aec916c72..38bcc86cc6 100644 --- a/basis/io/files/links/links.factor +++ b/basis/io/files/links/links.factor @@ -28,7 +28,7 @@ ERROR: too-many-symlinks path n ; : (follow-links) ( n path -- path' ) over 0 = [ symlink-depth get too-many-symlinks ] when dup link-info type>> +symbolic-link+ = - [ [ 1- ] [ follow-link ] bi* (follow-links) ] + [ [ 1 - ] [ follow-link ] bi* (follow-links) ] [ nip ] if ; inline recursive PRIVATE> diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index dd5eb5c8d9..ef7d778abe 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -4,7 +4,7 @@ io.pathnames namespaces ; IN: io.files.links.unix.tests : make-test-links ( n path -- ) - [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ] + [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ] [ [ number>string ] dip prepend touch-file ] 2bi ; inline [ t ] [ diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 7de6c25a13..d17cd1ff80 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -47,7 +47,7 @@ TUPLE: CreateProcess-args : count-trailing-backslashes ( str n -- str n ) [ "\\" ?tail ] dip swap [ - 1+ count-trailing-backslashes + 1 + count-trailing-backslashes ] when ; : fix-trailing-backslashes ( str -- str' ) diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index db8e02ae73..7329e73a80 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -14,13 +14,13 @@ SYMBOL: dummy-monitor-disposed TUPLE: dummy-monitor < monitor ; M: dummy-monitor dispose - drop dummy-monitor-disposed get [ 1+ ] change-i drop ; + drop dummy-monitor-disposed get [ 1 + ] change-i drop ; M: mock-io-backend (monitor) nip over exists? [ dummy-monitor new-monitor - dummy-monitor-created get [ 1+ ] change-i drop + dummy-monitor-created get [ 1 + ] change-i drop ] [ "Does not exist" throw ] if ; diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index c15663b031..8d747086a7 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -47,7 +47,7 @@ M: callable run-pipeline-element PRIVATE> : run-pipeline ( seq -- results ) - [ length dup zero? [ drop { } ] [ 1- ] if ] keep + [ length dup zero? [ drop { } ] [ 1 - ] if ] keep [ [ [ first in>> ] [ second out>> ] bi ] dip run-pipeline-element diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index e72b267c04..07246354e3 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -36,7 +36,7 @@ TUPLE: openssl-context < secure-context aliens sessions ; password [ B{ 0 } password! ] unless [let | len [ password strlen ] | - buf password len 1+ size min memcpy + buf password len 1 + size min memcpy len ] ] alien-callback ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fe136cd887..ec8b4206e3 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -19,7 +19,7 @@ IN: io.sockets.unix [ handle-fd ] 2dip 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) - dup zero? [ drop ] [ gai_strerror throw ] if ; + [ gai_strerror throw ] unless-zero ; ! Client sockets - TCP and Unix domain M: object (get-local-address) ( handle remote -- sockaddr ) diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index ab4fbd60bb..aabd4bbafc 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -5,18 +5,18 @@ IN: lcs ] with map ; @@ -25,7 +25,7 @@ IN: lcs [ [ + ] curry map ] with map ; :: run-lcs ( old new init step -- matrix ) - [let | matrix [ old length 1+ new length 1+ init call ] | + [let | matrix [ old length 1 + new length 1 + init call ] | old length [| i | new length [| j | i j matrix old new step loop-step ] each @@ -44,14 +44,14 @@ TUPLE: insert item ; TUPLE: trace-state old new table i j ; : old-nth ( state -- elt ) - [ i>> 1- ] [ old>> ] bi nth ; + [ i>> 1 - ] [ old>> ] bi nth ; : new-nth ( state -- elt ) - [ j>> 1- ] [ new>> ] bi nth ; + [ j>> 1 - ] [ new>> ] bi nth ; : top-beats-side? ( state -- ? ) - [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ] - [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ; + [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth nth ] + [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth nth ] bi > ; : retained? ( state -- ? ) { @@ -61,7 +61,7 @@ TUPLE: trace-state old new table i j ; : do-retain ( state -- state ) dup old-nth retain boa , - [ 1- ] change-i [ 1- ] change-j ; + [ 1 - ] change-i [ 1 - ] change-j ; : inserted? ( state -- ? ) { @@ -70,7 +70,7 @@ TUPLE: trace-state old new table i j ; } 1&& ; : do-insert ( state -- state ) - dup new-nth insert boa , [ 1- ] change-j ; + dup new-nth insert boa , [ 1 - ] change-j ; : deleted? ( state -- ? ) { @@ -79,7 +79,7 @@ TUPLE: trace-state old new table i j ; } 1&& ; : do-delete ( state -- state ) - dup old-nth delete boa , [ 1- ] change-i ; + dup old-nth delete boa , [ 1 - ] change-i ; : (trace-diff) ( state -- ) { @@ -90,7 +90,7 @@ TUPLE: trace-state old new table i j ; } cond ; : trace-diff ( old new table -- diff ) - [ ] [ first length 1- ] [ length 1- ] tri trace-state boa + [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa [ (trace-diff) ] { } make reverse ; PRIVATE> diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor index 5030e93abc..603b04e895 100644 --- a/basis/linked-assocs/linked-assocs-tests.factor +++ b/basis/linked-assocs/linked-assocs-tests.factor @@ -50,8 +50,8 @@ IN: linked-assocs.test { 9 } [ - { [ 3 * ] [ 1- ] } "first" pick set-at - { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at + { [ 3 * ] [ 1 - ] } "first" pick set-at + { [ [ 1 - ] bi@ ] [ 2 / ] } "second" pick set-at 4 6 pick values [ first call ] each + swap values [ second call ] each ] unit-test @@ -62,4 +62,4 @@ IN: linked-assocs.test 2 "by" pick set-at 3 "cx" pick set-at >alist -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index bde26e2fb9..7b386e9c81 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -97,7 +97,7 @@ M: lazy-take car ( lazy-take -- car ) cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ n>> 1- ] keep + [ n>> 1 - ] keep cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- ? ) @@ -191,7 +191,7 @@ TUPLE: lazy-from-by n quot ; C: lfrom-by lazy-from-by : lfrom ( n -- list ) - [ 1+ ] lfrom-by ; + [ 1 + ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) n>> ; @@ -235,7 +235,7 @@ M: sequence-cons car ( sequence-cons -- car ) [ index>> ] [ seq>> nth ] bi ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ; + [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ; M: sequence-cons nil? ( sequence-cons -- ? ) drop f ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index e34a719c57..d2f969cddc 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -24,7 +24,7 @@ IN: lists.tests ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } sequence>list [ 1+ ] lmap + { 1 2 3 4 } sequence>list [ 1 + ] lmap ] unit-test { 15 } [ diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 0eedb80889..ddf1ab9109 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -71,7 +71,7 @@ PRIVATE> ] if ; inline recursive : llength ( list -- n ) - 0 [ drop 1+ ] foldl ; + 0 [ drop 1 + ] foldl ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 9ec8e30133..1caa4b746f 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -38,7 +38,7 @@ USING: kernel literals math prettyprint ; IN: scratchpad << CONSTANT: five 5 >> -{ $[ five dup 1+ dup 2 + ] } . +{ $[ five dup 1 + dup 2 + ] } . "> "{ 5 6 8 }" } } ; @@ -69,7 +69,7 @@ USE: literals IN: scratchpad CONSTANT: five 5 -{ $ five $[ five dup 1+ dup 2 + ] } . +{ $ five $[ five dup 1 + dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index b1f0b6ca17..0f94e0591a 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -175,8 +175,8 @@ $nl { $code ":: counter ( -- )" " [let | value! [ 0 ] |" - " [ value 1+ dup value! ]" - " [ value 1- dup value! ] ] ;" + " [ value 1 + dup value! ]" + " [ value 1 - dup value! ] ] ;" } "Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array." $nl diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 414b2da45c..63b6d68feb 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -199,23 +199,23 @@ DEFER: xyzzy [ 5 ] [ 10 xyzzy ] unit-test :: let*-test-1 ( a -- b ) - [let* | b [ a 1+ ] - c [ b 1+ ] | + [let* | b [ a 1 + ] + c [ b 1 + ] | a b c 3array ] ; [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test :: let*-test-2 ( a -- b ) - [let* | b [ a 1+ ] - c! [ b 1+ ] | + [let* | b [ a 1 + ] + c! [ b 1 + ] | a b c 3array ] ; [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test :: let*-test-3 ( a -- b ) - [let* | b [ a 1+ ] - c! [ b 1+ ] | - c 1+ c! a b c 3array ] ; + [let* | b [ a 1 + ] + c! [ b 1 + ] | + c 1 + c! a b c 3array ] ; [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test @@ -502,7 +502,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ 3 ] [ 3 [| | :> a! a ] call ] unit-test -[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test +[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test :: wlet-&&-test ( a -- ? ) [wlet | is-integer? [ a integer? ] diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 8374ab421b..848ad5d40e 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -74,7 +74,7 @@ CONSTANT: keep-logs 10 over exists? [ move-file ] [ 2drop ] if ; : advance-log ( path n -- ) - [ 1- log# ] 2keep log# ?move-file ; + [ 1 - log# ] 2keep log# ?move-file ; : rotate-log ( service -- ) dup close-log diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 0fbfdf0bd9..e469140ff4 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline + [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline M: bits length length>> ; @@ -16,4 +16,4 @@ M: bits nth-unsafe number>> swap bit? ; INSTANCE: bits immutable-sequence : unbits ( seq -- number ) - 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ; + 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ; diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 041539c981..0e0b7ae167 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -28,7 +28,7 @@ HELP: nCk HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } -{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } +{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." } { $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 41800e46da..0fe77fa4ae 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -50,8 +50,10 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsection exp } { $subsection cis } { $subsection log } +{ $subsection log10 } "Raising a number to a power:" { $subsection ^ } +{ $subsection 10^ } "Converting between rectangular and polar form:" { $subsection abs } { $subsection absq } @@ -122,6 +124,10 @@ HELP: log { $values { "x" number } { "y" number } } { $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; +HELP: log10 +{ $values { "x" number } { "y" number } } +{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ; + HELP: sqrt { $values { "x" number } { "y" number } } { $description "Square root function." } ; @@ -261,6 +267,10 @@ HELP: ^ { $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; +HELP: 10^ +{ $values { "x" number } { "y" number } } +{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ; + HELP: gcd { $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } } { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } } diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 314062591d..801522b376 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -71,7 +71,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline + [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline : (^mod) ( n x y -- z ) make-bits 1 [ @@ -104,10 +104,12 @@ PRIVATE> : divisor? ( m n -- ? ) mod 0 = ; +ERROR: non-trivial-divisor n ; + : mod-inv ( x n -- y ) [ nip ] [ gcd 1 = ] 2bi [ dup 0 < [ + ] [ nip ] if ] - [ "Non-trivial divisor found" throw ] if ; foldable + [ non-trivial-divisor ] if ; foldable : ^mod ( x y n -- z ) over 0 < [ @@ -156,6 +158,10 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; M: complex log >polar swap flog swap rect> ; +: 10^ ( x -- y ) 10 swap ^ ; inline + +: log10 ( x -- y ) log 10 log / ; inline + GENERIC: cos ( x -- y ) foldable M: complex cos @@ -259,13 +265,13 @@ M: real atan fatan ; : round ( x -- y ) dup sgn 2 / + truncate ; inline : floor ( x -- y ) - dup 1 mod dup zero? - [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable + dup 1 mod + [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable : ceiling ( x -- y ) neg floor neg ; foldable : floor-to ( x step -- y ) - dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ; + [ [ / floor ] [ * ] bi ] unless-zero ; : lerp ( a b t -- a_t ) [ over - ] dip * + ; inline diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 2b8b3dff24..de402b48b9 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -1,10 +1,12 @@ USING: math.intervals kernel sequences words math math.order arrays prettyprint tools.test random vocabs combinators -accessors math.constants ; +accessors math.constants fry ; IN: math.intervals.tests [ empty-interval ] [ 2 2 (a,b) ] unit-test +[ empty-interval ] [ 2 2.0 (a,b) ] unit-test + [ empty-interval ] [ 2 2 [a,b) ] unit-test [ empty-interval ] [ 2 2 (a,b] ] unit-test @@ -111,6 +113,22 @@ IN: math.intervals.tests 0 1 (a,b) 0 1 [a,b] interval-subset? ] unit-test +[ t ] [ + full-interval -1/0. 1/0. [a,b] interval-subset? +] unit-test + +[ t ] [ + -1/0. 1/0. [a,b] full-interval interval-subset? +] unit-test + +[ f ] [ + full-interval 0 1/0. [a,b] interval-subset? +] unit-test + +[ t ] [ + 0 1/0. [a,b] full-interval interval-subset? +] unit-test + [ f ] [ 0 0 1 (a,b) interval-contains? ] unit-test @@ -189,6 +207,10 @@ IN: math.intervals.tests [ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test +[ f ] [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test + +[ f ] [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test + [ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test [ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test @@ -211,6 +233,10 @@ IN: math.intervals.tests [ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test +! Accuracy of interval-mod +[ t ] [ full-interval 40 40 [a,b] interval-mod -40 40 (a,b) interval-subset? +] unit-test + ! Interval random tester : random-element ( interval -- n ) dup full-interval eq? [ @@ -236,7 +262,7 @@ IN: math.intervals.tests } case ] if ; -: random-unary-op ( -- pair ) +: unary-ops ( -- alist ) { { bitnot interval-bitnot } { abs interval-abs } @@ -247,11 +273,10 @@ IN: math.intervals.tests } "math.ratios.private" vocab [ { recip interval-recip } suffix - ] when - random ; + ] when ; -: unary-test ( -- ? ) - random-interval random-unary-op ! 2dup . . +: unary-test ( op -- ? ) + [ random-interval ] dip 0 pick interval-contains? over first \ recip eq? and [ 2drop t ] [ @@ -259,9 +284,11 @@ IN: math.intervals.tests second execute( a -- b ) interval-contains? ] if ; -[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test +unary-ops [ + [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test +] each -: random-binary-op ( -- pair ) +: binary-ops ( -- alist ) { { + interval+ } { - interval- } @@ -272,17 +299,15 @@ IN: math.intervals.tests { bitand interval-bitand } { bitor interval-bitor } { bitxor interval-bitxor } - ! { shift interval-shift } { min interval-min } { max interval-max } } "math.ratios.private" vocab [ { / interval/ } suffix - ] when - random ; + ] when ; -: binary-test ( -- ? ) - random-interval random-interval random-binary-op ! 3dup . . . +: binary-test ( op -- ? ) + [ random-interval random-interval ] dip 0 pick interval-contains? over first { / /i mod rem } member? and [ 3drop t ] [ @@ -290,22 +315,26 @@ IN: math.intervals.tests second execute( a b -- c ) interval-contains? ] if ; -[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test +binary-ops [ + [ [ t ] ] dip '[ 8000 iota [ drop _ binary-test ] all? ] unit-test +] each -: random-comparison ( -- pair ) +: comparison-ops ( -- alist ) { { < interval< } { <= interval<= } { > interval> } { >= interval>= } - } random ; + } ; -: comparison-test ( -- ? ) - random-interval random-interval random-comparison +: comparison-test ( op -- ? ) + [ random-interval random-interval ] dip [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; -[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test +comparison-ops [ + [ [ t ] ] dip '[ 8000 iota [ drop _ comparison-test ] all? ] unit-test +] each [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test @@ -325,18 +354,19 @@ IN: math.intervals.tests : random-interval-or-empty ( -- obj ) 10 random 0 = [ empty-interval ] [ random-interval ] if ; -: random-commutative-op ( -- op ) +: commutative-ops ( -- seq ) { interval+ interval* interval-bitor interval-bitand interval-bitxor interval-max interval-min - } random ; + } ; -[ t ] [ - 80000 iota [ - drop - random-interval-or-empty random-interval-or-empty - random-commutative-op - [ execute ] [ swapd execute ] 3bi = - ] all? -] unit-test +commutative-ops [ + [ [ t ] ] dip '[ + 8000 iota [ + drop + random-interval-or-empty random-interval-or-empty _ + [ execute ] [ swapd execute ] 3bi = + ] all? + ] unit-test +] each diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 767197a975..8ea28b2235 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman. +! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order -combinators generic layouts ; +combinators generic layouts memoize ; IN: math.intervals SYMBOL: empty-interval @@ -11,14 +11,21 @@ SYMBOL: full-interval TUPLE: interval { from read-only } { to read-only } ; +: closed-point? ( from to -- ? ) + 2dup [ first ] bi@ number= + [ [ second ] both? ] [ 2drop f ] if ; + : ( from to -- interval ) - 2dup [ first ] bi@ { - { [ 2dup > ] [ 2drop 2drop empty-interval ] } - { [ 2dup = ] [ - 2drop 2dup [ second ] both? + { + { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] } + { [ 2dup [ first ] bi@ number= ] [ + 2dup [ second ] both? [ interval boa ] [ 2drop empty-interval ] if ] } - [ 2drop interval boa ] + { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [ + 2drop full-interval + ] } + [ interval boa ] } cond ; : open-point ( n -- endpoint ) f 2array ; @@ -48,7 +55,13 @@ TUPLE: interval { from read-only } { to read-only } ; : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline -: [0,inf] ( -- interval ) 0 [a,inf] ; foldable +MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable + +MEMO: fixnum-interval ( -- interval ) + most-negative-fixnum most-positive-fixnum [a,b] ; inline + +MEMO: array-capacity-interval ( -- interval ) + 0 max-array-capacity [a,b] ; inline : [-inf,inf] ( -- interval ) full-interval ; inline @@ -56,20 +69,23 @@ TUPLE: interval { from read-only } { to read-only } ; [ 2dup [ first ] bi@ ] dip call [ 2drop t ] [ - 2dup [ first ] bi@ = [ + 2dup [ first ] bi@ number= [ [ second ] bi@ not or ] [ 2drop f ] if ] if ; inline +: endpoint= ( p1 p2 -- ? ) + [ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ; + : endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ; -: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ; +: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ; : endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ; -: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ; +: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ; : endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ; @@ -180,7 +196,7 @@ TUPLE: interval { from read-only } { to read-only } ; ] [ interval>points 2dup [ second ] both? - [ [ first ] bi@ = ] + [ [ first ] bi@ number= ] [ 2drop f ] if ] if ; @@ -269,22 +285,6 @@ TUPLE: interval { from read-only } { to read-only } ; [ (interval-abs) points>interval ] } cond ; -: interval-mod ( i1 i2 -- i3 ) - #! Inaccurate. - [ - [ - nip interval-abs to>> first [ neg ] keep (a,b) - ] interval-division-op - ] do-empty-interval ; - -: interval-rem ( i1 i2 -- i3 ) - #! Inaccurate. - [ - [ - nip interval-abs to>> first 0 swap [a,b) - ] interval-division-op - ] do-empty-interval ; - : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; @@ -294,13 +294,13 @@ SYMBOL: incomparable : left-endpoint-< ( i1 i2 -- ? ) [ swap interval-subset? ] [ nip interval-singleton? ] - [ [ from>> ] bi@ = ] + [ [ from>> ] bi@ endpoint= ] 2tri and and ; : right-endpoint-< ( i1 i2 -- ? ) [ interval-subset? ] [ drop interval-singleton? ] - [ [ to>> ] bi@ = ] + [ [ to>> ] bi@ endpoint= ] 2tri and and ; : (interval<) ( i1 i2 -- i1 i2 ? ) @@ -316,10 +316,10 @@ SYMBOL: incomparable } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) - [ from>> ] dip to>> = ; + [ from>> ] [ to>> ] bi* endpoint= ; : right-endpoint-<= ( i1 i2 -- ? ) - [ to>> ] dip from>> = ; + [ to>> ] [ from>> ] bi* endpoint= ; : interval<= ( i1 i2 -- ? ) { @@ -335,6 +335,25 @@ SYMBOL: incomparable : interval>= ( i1 i2 -- ? ) swap interval<= ; +: interval-mod ( i1 i2 -- i3 ) + { + { [ over empty-interval eq? ] [ swap ] } + { [ dup empty-interval eq? ] [ ] } + { [ dup full-interval eq? ] [ ] } + [ interval-abs to>> first [ neg ] keep (a,b) ] + } cond + swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ; + +: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ; + +: interval-rem ( i1 i2 -- i3 ) + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ dup full-interval eq? ] [ 2drop [0,inf] ] } + [ nip (rem-range) ] + } cond ; + : interval-bitand-pos ( i1 i2 -- ? ) [ to>> first ] bi@ min 0 swap [a,b] ; diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 0368dd5286..8411447aac 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -50,7 +50,7 @@ SYMBOL: matrix : do-row ( exchange-with row# -- ) [ exchange-rows ] keep [ first-col ] keep - dup 1+ rows-from clear-col ; + dup 1 + rows-from clear-col ; : find-row ( row# quot -- i elt ) [ rows-from ] dip find ; inline @@ -60,8 +60,8 @@ SYMBOL: matrix : (echelon) ( col# row# -- ) over cols < over rows < and [ - 2dup pivot-row [ over do-row 1+ ] when* - [ 1+ ] dip (echelon) + 2dup pivot-row [ over do-row 1 + ] when* + [ 1 + ] dip (echelon) ] [ 2drop ] if ; diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index 673f9c97cd..fdc2f9fc3b 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -9,7 +9,7 @@ IN: math.primes.erato CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 } : bit-pos ( n -- byte/f mask/f ) - 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ; + 30 /mod masks nth-unsafe [ drop f f ] when-zero ; : marked-unsafe? ( n arr -- ? ) [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ; @@ -38,4 +38,4 @@ PRIVATE> : marked-prime? ( n arr -- ? ) 2dup upper-bound 2 swap between? [ bounds-error ] unless - over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; \ No newline at end of file + over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 439d55ee8d..da1c36196b 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -8,7 +8,7 @@ IN: math.primes.factors : count-factor ( n d -- n' c ) [ 1 ] 2dip [ /i ] keep - [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop + [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop swap ; : write-factor ( n d -- n' d' ) @@ -39,7 +39,7 @@ PRIVATE> : totient ( n -- t ) { { [ dup 2 < ] [ drop 0 ] } - [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ] + [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ] } cond ; foldable : divisors ( n -- seq ) diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index c01e7377b2..8124fcdd24 100644 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -78,8 +78,8 @@ unit-test [ 3 ] [ 10/3 truncate ] unit-test [ -3 ] [ -10/3 truncate ] unit-test -[ -1/2 ] [ 1/2 1- ] unit-test -[ 3/2 ] [ 1/2 1+ ] unit-test +[ -1/2 ] [ 1/2 1 - ] unit-test +[ 3/2 ] [ 1/2 1 + ] unit-test [ 1.0 ] [ 0.5 1/2 + ] unit-test [ 1.0 ] [ 1/2 0.5 + ] unit-test diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d4f457180e..7da92cd154 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel kernel.private math math.functions math.private ; +USING: accessors kernel kernel.private math math.functions +math.private sequences summary ; IN: math.ratios : 2>fraction ( a/b c/d -- a c b d ) @@ -19,13 +20,18 @@ IN: math.ratios PRIVATE> +ERROR: division-by-zero x ; + +M: division-by-zero summary + drop "Division by zero" ; + M: integer / - dup zero? [ - "Division by zero" throw + [ + division-by-zero ] [ dup 0 < [ [ neg ] bi@ ] when 2dup gcd nip [ /i ] curry bi@ fraction> - ] if ; + ] if-zero ; M: ratio hashcode* nip >fraction [ hashcode ] bi@ bitxor ; diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor new file mode 100644 index 0000000000..5b6f1eac71 --- /dev/null +++ b/basis/math/vectors/specialization/specialization-tests.factor @@ -0,0 +1,21 @@ +IN: math.vectors.specialization.tests +USING: compiler.tree.debugger math.vectors tools.test kernel +kernel.private math specialized-arrays.double +specialized-arrays.complex-float +specialized-arrays.float ; + +[ V{ t } ] [ + [ { double-array double-array } declare distance 0.0 < not ] final-literals +] unit-test + +[ V{ float } ] [ + [ { float-array float } declare v*n norm ] final-classes +] unit-test + +[ V{ number } ] [ + [ { complex-float-array complex-float-array } declare v. ] final-classes +] unit-test + +[ V{ real } ] [ + [ { complex-float-array complex } declare v*n norm ] final-classes +] unit-test \ No newline at end of file diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor new file mode 100644 index 0000000000..c9db3e02b3 --- /dev/null +++ b/basis/math/vectors/specialization/specialization.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel make sequences effects kernel.private accessors +combinators math math.intervals math.vectors namespaces assocs fry +splitting classes.algebra generalizations +compiler.tree.propagation.info ; +IN: math.vectors.specialization + +SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; + +: signature-for-schema ( array-type elt-type schema -- signature ) + [ + { + { +vector+ [ drop ] } + { +scalar+ [ nip ] } + { +nonnegative+ [ nip ] } + } case + ] with with map ; + +: (specialize-vector-word) ( word array-type elt-type schema -- word' ) + signature-for-schema + [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f ] + [ [ , \ declare , def>> % ] [ ] make ] + [ drop stack-effect ] + 2tri + [ define-declared ] [ 2drop ] 3bi ; + +: output-infos ( array-type elt-type schema -- value-infos ) + [ + { + { +vector+ [ drop ] } + { +scalar+ [ nip ] } + { +nonnegative+ [ nip real class-and [0,inf] ] } + } case + ] with with map ; + +: record-output-signature ( word array-type elt-type schema -- word ) + output-infos + [ drop ] + [ drop ] + [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri + "outputs" set-word-prop ; + +CONSTANT: vector-words +H{ + { [v-] { +vector+ +vector+ -> +vector+ } } + { distance { +vector+ +vector+ -> +nonnegative+ } } + { n*v { +scalar+ +vector+ -> +vector+ } } + { n+v { +scalar+ +vector+ -> +vector+ } } + { n-v { +scalar+ +vector+ -> +vector+ } } + { n/v { +scalar+ +vector+ -> +vector+ } } + { norm { +vector+ -> +nonnegative+ } } + { norm-sq { +vector+ -> +nonnegative+ } } + { normalize { +vector+ -> +vector+ } } + { v* { +vector+ +vector+ -> +vector+ } } + { v*n { +vector+ +scalar+ -> +vector+ } } + { v+ { +vector+ +vector+ -> +vector+ } } + { v+n { +vector+ +scalar+ -> +vector+ } } + { v- { +vector+ +vector+ -> +vector+ } } + { v-n { +vector+ +scalar+ -> +vector+ } } + { v. { +vector+ +vector+ -> +scalar+ } } + { v/ { +vector+ +vector+ -> +vector+ } } + { v/n { +vector+ +scalar+ -> +vector+ } } + { vceiling { +vector+ -> +vector+ } } + { vfloor { +vector+ -> +vector+ } } + { vmax { +vector+ +vector+ -> +vector+ } } + { vmin { +vector+ +vector+ -> +vector+ } } + { vneg { +vector+ -> +vector+ } } + { vtruncate { +vector+ -> +vector+ } } +} + +SYMBOL: specializations + +specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize + +: add-specialization ( new-word signature word -- ) + specializations get at set-at ; + +: word-schema ( word -- schema ) vector-words at ; + +: inputs ( schema -- seq ) { -> } split first ; + +: outputs ( schema -- seq ) { -> } split second ; + +: specialize-vector-word ( word array-type elt-type -- word' ) + pick word-schema + [ inputs (specialize-vector-word) ] + [ outputs record-output-signature ] 3bi ; + +: input-signature ( word -- signature ) def>> first ; + +: specialize-vector-words ( array-type elt-type -- ) + [ vector-words keys ] 2dip + '[ + [ _ _ specialize-vector-word ] keep + [ dup input-signature ] dip + add-specialization + ] each ; + +: find-specialization ( classes word -- word/f ) + specializations get at + [ first [ class<= ] 2all? ] with find + swap [ second ] when ; + +: vector-word-custom-inlining ( #call -- word/f ) + [ in-d>> [ value-info class>> ] map ] [ word>> ] bi + find-specialization ; + +vector-words keys [ + [ vector-word-custom-inlining ] + "custom-inlining" set-word-prop +] each \ No newline at end of file diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 14a66b5c18..dd48525b53 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,9 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; + + : trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) [ first lerp ] [ second lerp ] [ third lerp ] tri-curry [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index d82abe5b07..771c11c130 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail MEMO: see-test ( a -- b ) reverse ; diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 0cf7556bcd..1d56c59fc0 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -46,7 +46,7 @@ ERROR: end-of-stream multipart ; dup bytes>> length 256 < [ fill-bytes ] when ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) - dupd [ length ] bi@ 1- - short cut-slice swap ; + dupd [ length ] bi@ 1 - - short cut-slice swap ; : dump-until-separator ( multipart -- multipart ) dup diff --git a/basis/models/arrow/arrow-tests.factor b/basis/models/arrow/arrow-tests.factor index 6984e0e750..d7900f1dbd 100644 --- a/basis/models/arrow/arrow-tests.factor +++ b/basis/models/arrow/arrow-tests.factor @@ -4,7 +4,7 @@ IN: models.arrow.tests 3 "x" set "x" get [ 2 * ] dup "z" set -[ 1+ ] "y" set +[ 1 + ] "y" set [ ] [ "y" get activate-model ] unit-test [ t ] [ "z" get "x" get connections>> memq? ] unit-test [ 7 ] [ "y" get value>> ] unit-test diff --git a/extra/str-fry/authors.txt b/basis/models/illusion/authors.txt similarity index 100% rename from extra/str-fry/authors.txt rename to basis/models/illusion/authors.txt diff --git a/basis/models/illusion/illusion.factor b/basis/models/illusion/illusion.factor new file mode 100644 index 0000000000..00169792a9 --- /dev/null +++ b/basis/models/illusion/illusion.factor @@ -0,0 +1,15 @@ +USING: accessors models models.arrow inverse kernel ; +IN: models.illusion + +TUPLE: illusion < arrow ; + +: ( model quot -- illusion ) + illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref + swap >>quot over >>model [ add-dependency ] keep ; + +: ( model quot -- illusion ) dup activate-model ; + +: backtalk ( value object -- ) + [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ; + +M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ; \ No newline at end of file diff --git a/basis/models/illusion/summary.txt b/basis/models/illusion/summary.txt new file mode 100644 index 0000000000..8ea7cf1e7d --- /dev/null +++ b/basis/models/illusion/summary.txt @@ -0,0 +1 @@ +Two Way Arrows \ No newline at end of file diff --git a/basis/models/models.factor b/basis/models/models.factor index 19b478eaf9..27504bc0fa 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -32,10 +32,10 @@ GENERIC: model-activated ( model -- ) M: model model-activated drop ; : ref-model ( model -- n ) - [ 1+ ] change-ref ref>> ; + [ 1 + ] change-ref ref>> ; : unref-model ( model -- n ) - [ 1- ] change-ref ref>> ; + [ 1 - ] change-ref ref>> ; : activate-model ( model -- ) dup ref-model 1 = [ diff --git a/basis/models/product/product-tests.factor b/basis/models/product/product-tests.factor index 84ac738126..f52dc8a3b0 100644 --- a/basis/models/product/product-tests.factor +++ b/basis/models/product/product-tests.factor @@ -24,7 +24,7 @@ IN: models.product.tests TUPLE: an-observer { i integer } ; -M: an-observer model-changed nip [ 1+ ] change-i drop ; +M: an-observer model-changed nip [ 1 + ] change-i drop ; [ 1 0 ] [ [let* | m1 [ 1 ] @@ -42,4 +42,4 @@ M: an-observer model-changed nip [ 1+ ] change-i drop ; o1 i>> o2 i>> ] -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 2e8f8eb4c4..c0d109e3c5 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -44,7 +44,7 @@ PRIVATE> : parse-multiline-string ( end-text -- str ) [ lexer get - [ 1+ swap (parse-multiline-string) ] + [ 1 + swap (parse-multiline-string) ] change-column drop ] "" make ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 9aa4ee429d..6292a683e3 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -25,7 +25,7 @@ reset-gl-function-number-counter : gl-function-number ( -- n ) +gl-function-number-counter+ get-global - dup 1+ +gl-function-number-counter+ set-global ; + dup 1 + +gl-function-number-counter+ set-global ; : gl-function-pointer ( names n -- funptr ) gl-function-context 2array dup +gl-function-pointers+ get-global at diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 93f407681e..850b585190 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -51,7 +51,7 @@ PRIVATE> dup zero? [ 2drop epsilon ] [ - [ exactly-n ] [ 1- at-most-n ] 2bi 2choice + [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice ] if ; : at-least-n ( parser n -- parser' ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 12e6d59fc0..42530151be 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -329,7 +329,7 @@ SYMBOL: id : next-id ( -- n ) #! Return the next unique id for a parser id get-global [ - dup 1+ id set-global + dup 1 + id set-global ] [ 1 id set-global 0 ] if* ; diff --git a/basis/persistent/hashtables/config/config.factor b/basis/persistent/hashtables/config/config.factor index a761e2d327..cb2abd8015 100644 --- a/basis/persistent/hashtables/config/config.factor +++ b/basis/persistent/hashtables/config/config.factor @@ -4,5 +4,5 @@ USING: layouts kernel parser math ; IN: persistent.hashtables.config : radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable -: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable -: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline +: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable +: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 67886312c6..0179216e62 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -33,7 +33,7 @@ M: persistent-hash pluck-at { { [ 2dup root>> eq? ] [ nip ] } { [ over not ] [ 2drop T{ persistent-hash } ] } - [ count>> 1- persistent-hash boa ] + [ count>> 1 - persistent-hash boa ] } cond ; M: persistent-hash >alist [ root>> >alist% ] { } make ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index f231043274..4c764eba93 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -7,7 +7,7 @@ persistent.hashtables.config persistent.hashtables.nodes ; IN: persistent.hashtables.nodes.bitmap -: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline +: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry ) [let* | shift [ bitmap-node shift>> ] diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 5927171aa3..2527959f32 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -55,13 +55,13 @@ M: persistent-vector nth-unsafe [ 1array ] dip node boa ; : 2node ( first second -- node ) - [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) dup full? [ tuck level>> 1node ] [ node-add f ] if ; : new-last ( val seq -- seq' ) - [ length 1- ] keep new-nth ; + [ length 1 - ] keep new-nth ; : node-set-last ( child node -- node' ) clone [ new-last ] change-children ; @@ -86,7 +86,7 @@ M: persistent-vector ppush ( val pvec -- pvec' ) clone dup tail>> full? [ ppush-new-tail ] [ ppush-tail ] if - [ 1+ ] change-count ; + [ 1 + ] change-count ; : node-set-nth ( val i node -- node' ) clone [ new-nth ] change-children ; @@ -166,7 +166,7 @@ M: persistent-vector ppop ( pvec -- pvec' ) clone dup tail>> children>> length 1 > [ ppop-tail ] [ ppop-new-tail ] if - ] dip 1- >>count + ] dip 1 - >>count ] } case ; diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index 4765df10d7..2e1a47b951 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -7,7 +7,7 @@ IN: porter-stemmer ] [ CHAR: y = [ over zero? - [ 2drop t ] [ [ 1- ] dip consonant? not ] if + [ 2drop t ] [ [ 1 - ] dip consonant? not ] if ] [ 2drop t ] if @@ -15,18 +15,18 @@ IN: porter-stemmer : skip-vowels ( i str -- i str ) 2dup bounds-check? [ - 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless + 2dup consonant? [ [ 1 + ] dip skip-vowels ] unless ] when ; : skip-consonants ( i str -- i str ) 2dup bounds-check? [ - 2dup consonant? [ [ 1+ ] dip skip-consonants ] when + 2dup consonant? [ [ 1 + ] dip skip-consonants ] when ] when ; : (consonant-seq) ( n i str -- n ) skip-vowels 2dup bounds-check? [ - [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip + [ 1 + ] [ 1 + ] [ ] tri* skip-consonants [ 1 + ] dip (consonant-seq) ] [ 2drop @@ -42,7 +42,7 @@ IN: porter-stemmer over 1 < [ 2drop f ] [ - 2dup nth [ over 1- over nth ] dip = [ + 2dup nth [ over 1 - over nth ] dip = [ consonant? ] [ 2drop f @@ -92,7 +92,7 @@ IN: porter-stemmer { [ "bl" ?tail ] [ "ble" append ] } { [ "iz" ?tail ] [ "ize" append ] } { - [ dup length 1- over double-consonant? ] + [ dup length 1 - over double-consonant? ] [ dup "lsz" last-is? [ but-last-slice ] unless ] } { @@ -206,7 +206,7 @@ IN: porter-stemmer : ll->l ( str -- newstr ) { { [ dup last CHAR: l = not ] [ ] } - { [ dup length 1- over double-consonant? not ] [ ] } + { [ dup length 1 - over double-consonant? not ] [ ] } { [ dup consonant-seq 1 > ] [ but-last-slice ] } [ ] } cond ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 99913a803a..718de7e84c 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -73,7 +73,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1+ cut [ (remove-breakpoints) ] bi@ + 1 + cut [ (remove-breakpoints) ] bi@ [ -> ] glue ] [ drop @@ -109,4 +109,4 @@ SYMBOL: pprint-string-cells? ] each ] with-row ] each - ] tabular-output nl ; \ No newline at end of file + ] tabular-output nl ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 0e0c7afb82..040b6d8f7c 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -44,7 +44,7 @@ TUPLE: pprinter last-newline line-count indent ; line-limit? [ "..." write pprinter get return ] when - pprinter get [ 1+ ] change-line-count drop + pprinter get [ 1 + ] change-line-count drop nl do-indent ] if ; @@ -209,7 +209,7 @@ M: block short-section ( block -- ) TUPLE: text < section string ; : ( string style -- text ) - over length 1+ \ text new-section + over length 1 + \ text new-section swap >>style swap >>string ; @@ -310,8 +310,8 @@ SYMBOL: next : group-flow ( seq -- newseq ) [ dup length [ - 2dup 1- swap ?nth prev set - 2dup 1+ swap ?nth next set + 2dup 1 - swap ?nth prev set + 2dup 1 + swap ?nth next set swap nth dup split-before dup , split-after ] with each ] { } make { t } split harvest ; diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor index e82789ccbf..53af3a5178 100644 --- a/basis/quoted-printable/quoted-printable.factor +++ b/basis/quoted-printable/quoted-printable.factor @@ -29,7 +29,7 @@ IN: quoted-printable : take-some ( seqs -- seqs seq ) 0 over [ length + dup 76 >= ] find drop nip - [ 1- cut-slice swap ] [ f swap ] if* concat ; + [ 1 - cut-slice swap ] [ f swap ] if* concat ; : divide-lines ( strings -- strings ) [ dup ] [ take-some ] produce nip ; diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index dadf93fd43..e6661dc078 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -8,4 +8,4 @@ M: random-dummy seed-random ( seed obj -- ) (>>i) ; M: random-dummy random-32* ( obj -- r ) - [ dup 1+ ] change-i drop ; + [ dup 1 + ] change-i drop ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index a02abbb8ac..966c5b2e60 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -17,7 +17,7 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : y ( n seq -- y ) [ nth-unsafe 31 mask-bit ] - [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline + [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline : mt[k] ( offset n seq -- ) [ @@ -30,16 +30,16 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } [ seq>> [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ] - [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] + [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] bi ] [ 0 >>i drop ] bi ; inline : init-mt-formula ( i seq -- f(seq[i]) ) - dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline + dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline : init-mt-rest ( seq -- ) - n 1- swap '[ - _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi + n 1 - swap '[ + _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi ] each ; inline : init-mt-seq ( seed -- seq ) @@ -67,7 +67,7 @@ M: mersenne-twister seed-random ( mt seed -- ) M: mersenne-twister random-32* ( mt -- r ) [ next-index ] [ seq>> nth-unsafe mt-temper ] - [ [ 1+ ] change-i drop ] tri ; + [ [ 1 + ] change-i drop ] tri ; [ [ 32 random-bits ] with-system-random diff --git a/basis/random/random.factor b/basis/random/random.factor index 1962857d57..4c94e87928 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -39,7 +39,7 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; @@ -57,7 +57,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ] + [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; : delete-random ( seq -- elt ) diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index 2916ef7c32..90ab3342f2 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -56,7 +56,7 @@ M: at-least : to-times ( term n -- ast ) dup zero? [ 2drop epsilon ] - [ dupd 1- to-times 2array ] + [ dupd 1 - to-times 2array ] if ; M: from-to diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 5482734865..d8940bb829 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -35,13 +35,13 @@ M: $ question>quot drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ; M: ^ question>quot - drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ; + drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ; M: $unix question>quot drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ; M: ^unix question>quot - drop [ { [ drop zero? ] [ [ 1- ] dip ?nth CHAR: \n = ] } 2|| ] ; + drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ; M: word-break question>quot drop [ word-break-at? ] ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 21439640fe..4318986813 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -25,7 +25,7 @@ M: lookahead question>quot ! Returns ( index string -- ? ) M: lookbehind question>quot ! Returns ( index string -- ? ) term>> ast>dfa dfa>reverse-shortest-word - '[ [ 1- ] dip f _ execute ] ; + '[ [ 1 - ] dip f _ execute ] ; : check-string ( string -- string ) ! Make this configurable @@ -53,12 +53,12 @@ PRIVATE> :: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? ) i string regexp quot call dup [| j | j i j - reverse? [ swap [ 1+ ] bi@ ] when + reverse? [ swap [ 1 + ] bi@ ] when string ] [ drop f f f f ] if ; inline : search-range ( i string reverse? -- seq ) - [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline + [ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline :: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? ) f f f f @@ -93,7 +93,7 @@ PRIVATE> [ subseq ] map-matches ; : count-matches ( string regexp -- n ) - [ 0 ] 2dip [ 3drop 1+ ] each-match ; + [ 0 ] 2dip [ 3drop 1 + ] each-match ; dup skip-blank [ [ index-from ] 2keep [ swapd subseq ] - [ 2drop 1+ ] 3bi + [ 2drop 1 + ] 3bi ] change-lexer-column ; : parse-noblank-token ( lexer -- str/f ) @@ -220,4 +220,4 @@ USING: vocabs vocabs.loader ; "prettyprint" vocab [ "regexp.prettyprint" require -] when \ No newline at end of file +] when diff --git a/basis/sequences/complex/complex.factor b/basis/sequences/complex/complex.factor index 93f9727f75..730689eb4f 100644 --- a/basis/sequences/complex/complex.factor +++ b/basis/sequences/complex/complex.factor @@ -18,8 +18,8 @@ PRIVATE> M: complex-sequence length seq>> length -1 shift ; M: complex-sequence nth-unsafe - complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ; + complex@ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi rect> ; M: complex-sequence set-nth-unsafe complex@ [ [ real-part ] [ ] [ ] tri* set-nth-unsafe ] - [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ; + [ [ imaginary-part ] [ 1 + ] [ ] tri* set-nth-unsafe ] 3bi ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index b7e395fa35..2b4294bda4 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -47,11 +47,11 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ! The last case is needed because a very large number would ! otherwise be confused with a small number. : serialize-cell ( n -- ) - dup zero? [ drop 0 write1 ] [ + [ 0 write1 ] [ dup HEX: 7e <= [ HEX: 80 bitor write1 ] [ - dup log2 8 /i 1+ + dup log2 8 /i 1 + dup HEX: 7f >= [ HEX: ff write1 dup serialize-cell @@ -60,7 +60,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ] if >be write ] if - ] if ; + ] if-zero ; : deserialize-cell ( -- n ) read1 { @@ -79,12 +79,12 @@ M: f (serialize) ( obj -- ) drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup zero? [ - drop CHAR: z write1 + [ + CHAR: z write1 ] [ dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 serialize-cell - ] if ; + ] if-zero ; M: float (serialize) ( obj -- ) CHAR: F write1 @@ -295,4 +295,4 @@ PRIVATE> binary [ deserialize ] with-byte-reader ; : object>bytes ( obj -- bytes ) - binary [ serialize ] with-byte-writer ; \ No newline at end of file + binary [ serialize ] with-byte-writer ; diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index 8bc12e2704..78b1493920 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -4,9 +4,9 @@ IN: sorting.insertion = [ - n n 1- seq exchange - seq quot n 1- insert + n n 1 - [ seq nth quot call ] bi@ >= [ + n n 1 - seq exchange + seq quot n 1 - insert ] unless ] unless ; inline recursive PRIVATE> diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor index 02e47ca140..95324bd2d5 100644 --- a/basis/specialized-arrays/double/double.factor +++ b/basis/specialized-arrays/double/double.factor @@ -11,61 +11,14 @@ HINTS: { 2 } { 3 } ; HINTS: (double-array) { 2 } { 3 } ; -HINTS: vneg { array } { double-array } ; -HINTS: v*n { array object } { double-array float } ; -HINTS: n*v { array object } { float double-array } ; -HINTS: v/n { array object } { double-array float } ; -HINTS: n/v { object array } { float double-array } ; -HINTS: v+ { array array } { double-array double-array } ; -HINTS: v- { array array } { double-array double-array } ; -HINTS: v* { array array } { double-array double-array } ; -HINTS: v/ { array array } { double-array double-array } ; -HINTS: vmax { array array } { double-array double-array } ; -HINTS: vmin { array array } { double-array double-array } ; -HINTS: v. { array array } { double-array double-array } ; -HINTS: norm-sq { array } { double-array } ; -HINTS: norm { array } { double-array } ; -HINTS: normalize { array } { double-array } ; -HINTS: distance { array array } { double-array double-array } ; - ! Type functions USING: words classes.algebra compiler.tree.propagation.info math.intervals ; -{ v+ v- v* v/ vmax vmin } [ - [ - [ class>> double-array class<= ] both? - double-array object ? - ] "outputs" set-word-prop -] each - -{ n*v n/v } [ - [ - nip class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - -{ v*n v/n } [ - [ - drop class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - -{ vneg normalize } [ - [ - class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - \ norm-sq [ class>> double-array class<= [ float 0. 1/0. [a,b] ] [ object-info ] if ] "outputs" set-word-prop -\ v. [ - [ class>> double-array class<= ] both? - float object ? -] "outputs" set-word-prop - \ distance [ [ class>> double-array class<= ] both? [ float 0. 1/0. [a,b] ] [ object-info ] if diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index c6641463f9..1c855be1a4 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: functors sequences sequences.private prettyprint.custom -kernel words classes math parser alien.c-types byte-arrays -accessors summary ; +kernel words classes math math.vectors.specialization parser +alien.c-types byte-arrays accessors summary ; IN: specialized-arrays.functor ERROR: bad-byte-array-length byte-array type ; @@ -74,4 +74,6 @@ SYNTAX: A{ \ } [ >A ] parse-literal ; INSTANCE: A sequence +A T c-type-boxed-class specialize-vector-words + ;FUNCTOR diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 088de52766..3641345a3e 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -29,10 +29,10 @@ PRIVATE> [ length ] [ ] [ 1 over change-circular-start ] tri [ @ not [ , ] [ drop ] if ] 3each ] { } make - dup empty? [ over length 1- prefix ] when -1 prefix 2 clump + dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump swap ] dip - '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline + '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline PRIVATE> @@ -64,6 +64,6 @@ TUPLE: upward-slice < slice ; drop [ downward-slices ] [ stable-slices ] - [ upward-slices ] tri 3append [ [ from>> ] compare ] sort + [ upward-slices ] tri 3append [ from>> ] sort-with ] } case ; diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 338b052316..5411c885ad 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,7 @@ parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +stack-checker.recursive-state summary ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; @@ -98,8 +98,10 @@ M: object apply-object push-literal ; : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; -: bad-call ( -- ) - "call must be given a callable" time-bomb ; +ERROR: bad-call obj ; + +M: bad-call summary + drop "call must be given a callable" ; : infer-literal-quot ( literal -- ) dup recursive-quotation? [ @@ -110,7 +112,7 @@ M: object apply-object push-literal ; [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ - drop bad-call + value>> \ bad-call boa time-bomb ] if ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 6959e32452..0edbe5e53d 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -134,13 +134,17 @@ M: object infer-call* \ compose [ infer-compose ] "special" set-word-prop +ERROR: bad-executable obj ; + +M: bad-executable summary + drop "execute must be given a word" ; + : infer-execute ( -- ) pop-literal nip dup word? [ apply-object ] [ - drop - "execute must be given a word" time-bomb + \ bad-executable boa time-bomb ] if ; \ execute [ infer-execute ] "special" set-word-prop @@ -149,7 +153,7 @@ M: object infer-call* : infer- ( -- ) \ - peek-d literal value>> second 1+ { tuple } + peek-d literal value>> second 1 + { tuple } apply-word/effect ; \ [ infer- ] "special" set-word-prop diff --git a/basis/stuff.factor b/basis/stuff.factor deleted file mode 100644 index 2e5fa2dfae..0000000000 --- a/basis/stuff.factor +++ /dev/null @@ -1,20 +0,0 @@ - -: spill-integer-base ( -- n ) - stack-frame get spill-counts>> double-float-regs swap at - double-float-regs reg-size * ; - -: spill-integer@ ( n -- offset ) - cells spill-integer-base + param@ ; - -: spill-float@ ( n -- offset ) - double-float-regs reg-size * param@ ; - -: (stack-frame-size) ( stack-frame -- n ) - [ - { - [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] - [ gc-roots>> cells ] - [ params>> ] - [ return>> ] - } cleave - ] sum-outputs ; \ No newline at end of file diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index f4bd563481..931cb36ea9 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -17,7 +17,7 @@ IN: suffix-arrays : from-to ( index begin suffix-array -- from/f to/f ) swap '[ _ head? not ] - [ find-last-from drop dup [ 1+ ] when ] + [ find-last-from drop dup [ 1 + ] when ] [ find-from drop ] 3bi ; : ( from/f to/f seq -- slice ) diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 79aef90bea..c21e9e0c60 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -10,7 +10,7 @@ IN: tools.annotations.tests ! erg's bug GENERIC: some-generic ( a -- b ) -M: integer some-generic 1+ ; +M: integer some-generic 1 + ; [ 4 ] [ 3 some-generic ] unit-test @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1 - ;" eval( -- ) ] unit-test [ 2 ] [ 3 some-generic ] unit-test @@ -59,4 +59,4 @@ M: object my-generic ; : some-code ( -- ) f my-generic drop ; -[ ] [ some-code ] unit-test \ No newline at end of file +[ ] [ some-code ] unit-test diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index fb664c495c..7b9c8b43bc 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -9,7 +9,7 @@ IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) ch i full index-from [ :> i i accum push - accum i 1+ full t + accum i 1 + full t ] [ f -1 full f ] if* ; @@ -23,7 +23,7 @@ IN: tools.completion [ 2dup number= [ drop ] [ nip V{ } clone pick push ] if - 1+ + 1 + ] keep pick last push ] each ; @@ -33,9 +33,9 @@ IN: tools.completion : score-1 ( i full -- n ) { { [ over zero? ] [ 2drop 10 ] } - { [ 2dup length 1- number= ] [ 2drop 4 ] } - { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] } - { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] } + { [ 2dup length 1 - number= ] [ 2drop 4 ] } + { [ 2dup [ 1 - ] dip nth Letter? not ] [ 2drop 10 ] } + { [ 2dup [ 1 + ] dip nth Letter? not ] [ 2drop 4 ] } [ 2drop 1 ] } cond ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 270b55fda6..35e58a0aa7 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -293,6 +293,8 @@ IN: tools.deploy.shaker { } { "math.partial-dispatch" } strip-vocab-globals % + { } { "math.vectors.specialization" } strip-vocab-globals % + { } { "peg" } strip-vocab-globals % ] when diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index b53d4ef7a2..963ea7592c 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -14,14 +14,16 @@ M: source-file-error error-help error>> error-help ; CONSTANT: +listener-input+ "" -M: source-file-error summary +: error-location ( error -- string ) [ - [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] - [ line#>> [ # ] when* ] bi + [ file>> [ % ] [ +listener-input+ % ] if* ] + [ line#>> [ ": " % # ] when* ] bi ] "" make ; +M: source-file-error summary error>> summary ; + M: source-file-error error. - [ summary print nl ] + [ error-location print nl ] [ asset>> [ "Asset: " write short. nl ] when* ] [ error>> error. ] tri ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 7b07311ded..42721bada1 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -80,7 +80,7 @@ MACRO: ( word -- ) '[ _ ndup _ narray _ prefix ] ; : experiment. ( seq -- ) - [ first write ": " write ] [ rest . ] bi ; + [ first write ": " write ] [ rest . flush ] bi ; :: experiment ( word: ( -- error ? ) line# -- ) word :> e @@ -130,7 +130,7 @@ TEST: must-fail M: test-failure error. ( error -- ) { - [ summary print nl ] + [ error-location print nl ] [ asset>> [ experiment. nl ] when* ] [ error>> error. ] [ traceback-button. ] diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 03a86fe25f..f23989a1e2 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -202,7 +202,7 @@ PRIVATE> lf>crlf [ utf16n string>alien EmptyClipboard win32-error=0/f - GMEM_MOVEABLE over length 1+ GlobalAlloc + GMEM_MOVEABLE over length 1 + GlobalAlloc dup win32-error=0/f dup GlobalLock dup win32-error=0/f diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index aa2b9ca58c..b1b82a0542 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -495,7 +495,7 @@ TUPLE: multiline-editor < editor ; ; +: page-elt ( editor -- editor element ) dup visible-lines 1 - ; PRIVATE> @@ -526,7 +526,7 @@ PRIVATE> : this-line-and-next ( document line -- start end ) [ nip 0 swap 2array ] - [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ] + [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ] 2bi ; : last-line? ( document line -- ? ) diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index 34f4686518..168fb4bb11 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -23,7 +23,7 @@ M: glue pref-dim* drop { 0 0 } ; [ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline : available-space ( pref-dim gap dims -- avail ) - length 1+ * [-] ; inline + length 1 + * [-] ; inline : -center) ( pref-dim gap filled-cell dims -- ) [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline @@ -46,4 +46,4 @@ M: frame layout* [ ] dip new-grid ; inline : ( cols rows -- frame ) - frame new-frame ; \ No newline at end of file + frame new-frame ; diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index ade5c8101e..d7f77d9e54 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -78,10 +78,10 @@ TUPLE: mock-gadget < gadget graft-called ungraft-called ; mock-gadget new 0 >>graft-called 0 >>ungraft-called ; M: mock-gadget graft* - [ 1+ ] change-graft-called drop ; + [ 1 + ] change-graft-called drop ; M: mock-gadget ungraft* - [ 1+ ] change-ungraft-called drop ; + [ 1 + ] change-ungraft-called drop ; ! We can't print to output-stream here because that might be a pane ! stream, and our graft-queue rebinding here would be captured @@ -122,7 +122,7 @@ M: mock-gadget ungraft* 3 [ over >>model "g" get over add-gadget drop - swap 1+ number>string set + swap 1 + number>string set ] each ; : status-flags ( -- seq ) diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 0295012584..26d0fee2e3 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -395,4 +395,4 @@ M: f request-focus-on 2drop ; USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor index b9fe10c530..3292e3e6c5 100644 --- a/basis/ui/gadgets/line-support/line-support.factor +++ b/basis/ui/gadgets/line-support/line-support.factor @@ -28,10 +28,10 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ; : line>y ( n gadget -- y ) line-height * >integer ; : validate-line ( m gadget -- n ) - control-value [ drop f ] [ length 1- min 0 max ] if-empty ; + control-value [ drop f ] [ length 1 - min 0 max ] if-empty ; : valid-line? ( n gadget -- ? ) - control-value length 1- 0 swap between? ; + control-value length 1 - 0 swap between? ; : visible-line ( gadget quot -- n ) '[ @@ -43,7 +43,7 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ; [ loc>> ] visible-line ; : last-visible-line ( gadget -- n ) - [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ; + [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ; : each-slice-index ( from to seq quot -- ) [ [ ] [ drop [a,b) ] 3bi ] dip 2each ; inline @@ -85,4 +85,4 @@ M: line-gadget pref-viewport-dim 2bi 2array ; : visible-lines ( gadget -- n ) - [ visible-dim second ] [ line-height ] bi /i ; \ No newline at end of file + [ visible-dim second ] [ line-height ] bi /i ; diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 159da59be5..70818262c5 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -65,7 +65,7 @@ M: ---- : ( target hook -- menu ) over object-operations [ primary-operation? ] partition - [ reverse ] [ [ [ command-name ] compare ] sort ] bi* + [ reverse ] [ [ command-name ] sort-with ] bi* { ---- } glue ; : show-operations-menu ( gadget target hook -- ) diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index fc564b6ffe..9f55c7a67d 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -58,7 +58,7 @@ mouse-color column-line-color selection-required? single-click? -selected-value +selection min-rows min-cols max-rows diff --git a/basis/ui/gadgets/tables/tables-docs.factor b/basis/ui/gadgets/tables/tables-docs.factor index c064a80ee4..81e5f0f778 100644 --- a/basis/ui/gadgets/tables/tables-docs.factor +++ b/basis/ui/gadgets/tables/tables-docs.factor @@ -16,17 +16,17 @@ $nl { $subsection column-titles } ; ARTICLE: "ui.gadgets.tables.selection" "Table row selection" -"At any given time, a single row in the table may be selected." -$nl "A few slots in the table gadget concern row selection:" { $table - { { $slot "selected-value" } { " - if set to a model, the currently selected row's value, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } } - { { $slot "selected-index" } " - the index of the currently selected row." } + { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } } + { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } } { { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } } + { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } } } "Some words for row selection:" -{ $subsection selected-row } -{ $subsection (selected-row) } ; +{ $subsection selected-rows } +{ $subsection (selected-rows) } +{ $subsection selected } ; ARTICLE: "ui.gadgets.tables.actions" "Table row actions" "When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively." diff --git a/basis/ui/gadgets/tables/tables-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor index 3191753324..b92f72a2dd 100644 --- a/basis/ui/gadgets/tables/tables-tests.factor +++ b/basis/ui/gadgets/tables/tables-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.tables.tests USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors -models namespaces tools.test kernel combinators ; +models namespaces tools.test kernel combinators prettyprint arrays ; SINGLETON: test-renderer @@ -44,4 +44,19 @@ M: test-renderer column-titles drop { "First" "Last" } ; [ selected-row drop ] } cleave ] with-grafted-gadget -] unit-test \ No newline at end of file +] unit-test + +SINGLETON: silly-renderer + +M: silly-renderer row-columns drop unparse 1array ; + +M: silly-renderer column-titles drop { "Foo" } ; + +: test-table-2 ( -- table ) + { 1 2 f } silly-renderer ; + +[ f f ] [ + test-table dup [ + selected-row + ] with-grafted-gadget +] unit-test diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 3beb0af79f..ccc5550adb 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors colors.constants fry kernel math -math.functions math.rectangles math.order math.vectors namespaces -opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar -ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text -ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support -models math.ranges combinators -combinators.short-circuit fonts locals strings ; +USING: accessors assocs hashtables arrays colors colors.constants fry +kernel math math.functions math.ranges math.rectangles math.order +math.vectors namespaces opengl sequences ui.gadgets +ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds +ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images +ui.gadgets.menus ui.gadgets.line-support models combinators +combinators.short-circuit fonts locals strings sets sorting ; IN: ui.gadgets.tables ! Row rendererer protocol @@ -41,19 +41,44 @@ focus-border-color { mouse-color initial: COLOR: black } column-line-color selection-required? -selected-index selected-value +selection +selection-index +selected-indices mouse-index { takes-focus? initial: t } -focused? ; +focused? +multiple-selection? ; + +> conjoin ; + +: multiple>single ( values -- value/f ? ) + dup assoc-empty? [ drop f f ] [ values first t ] if ; + +: selected-index ( table -- n ) + selected-indices>> multiple>single drop ; + +: set-selected-index ( table n -- table ) + dup associate >>selected-indices ; + +PRIVATE> + +: selected ( table -- index/indices ) + [ selected-indices>> ] [ multiple-selection?>> ] bi + [ multiple>single drop ] unless ; : new-table ( rows renderer class -- table ) new-line-gadget swap >>renderer swap >>model - f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; inline + transparent >>column-line-color + f >>selection-index + f >>selection + H{ } clone >>selected-indices ; :
( rows renderer -- table ) table new-table ; @@ -131,21 +156,21 @@ M: table layout* : row-bounds ( table row -- loc dim ) row-rect rect-bounds ; inline -: draw-selected-row ( table -- ) +: draw-selected-rows ( table -- ) { - { [ dup selected-index>> not ] [ drop ] } + { [ dup selected-indices>> assoc-empty? ] [ drop ] } [ - [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri - row-bounds gl-fill-rect + [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri + [ swap row-bounds gl-fill-rect ] curry each ] } cond ; : draw-focused-row ( table -- ) { { [ dup focused?>> not ] [ drop ] } - { [ dup selected-index>> not ] [ drop ] } + { [ dup selected-index not ] [ drop ] } [ - [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri + [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri row-bounds gl-rect ] } cond ; @@ -189,10 +214,11 @@ M: table layout* dup renderer>> column-alignment [ ] [ column-widths>> length 0 ] ?if ; -:: row-font ( row index table -- font ) +:: row-font ( row ind table -- font ) table font>> clone row table renderer>> row-color [ >>foreground ] when* - index table selected-index>> = [ table selection-color>> >>background ] when ; + ind table selected-indices>> key? + [ table selection-color>> >>background ] when ; : draw-columns ( columns widths alignment font gap -- ) '[ [ _ ] 3dip _ draw-column ] 3each ; @@ -213,7 +239,7 @@ M: table draw-gadget* dup control-value empty? [ drop ] [ dup line-height \ line-height [ { - [ draw-selected-row ] + [ draw-selected-rows ] [ draw-lines ] [ draw-column-lines ] [ draw-focused-row ] @@ -236,17 +262,36 @@ M: table pref-dim* PRIVATE> -: (selected-row) ( table -- value/f ? ) - [ selected-index>> ] keep nth-row ; +: (selected-rows) ( table -- assoc ) + [ selected-indices>> ] keep + '[ _ nth-row drop ] assoc-map ; -: selected-row ( table -- value/f ? ) - [ (selected-row) ] keep - swap [ renderer>> row-value t ] [ 2drop f f ] if ; +: selected-rows ( table -- assoc ) + [ selected-indices>> ] [ ] [ renderer>> ] tri + '[ _ nth-row drop _ row-value ] assoc-map ; + +: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ; + +: selected-row ( table -- value/f ? ) selected-rows multiple>single ; > ] bi set-model ; +: set-table-model ( model value multiple? -- ) + [ values ] [ multiple>single drop ] if swap set-model ; + +: update-selected ( table -- ) + [ + [ selection>> ] + [ selected-rows ] + [ multiple-selection?>> ] tri + set-table-model + ] + [ + [ selection-index>> ] + [ selected-indices>> ] + [ multiple-selection?>> ] tri + set-table-model + ] bi ; : show-row-summary ( table n -- ) over nth-row @@ -258,51 +303,73 @@ PRIVATE> f >>mouse-index [ hide-status ] [ relayout-1 ] bi ; : find-row-index ( value table -- n/f ) - [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ; + [ model>> value>> ] [ renderer>> ] bi + '[ _ row-value eq? ] with find drop ; -: initial-selected-index ( table -- n/f ) +: (update-selected-indices) ( table -- set ) + [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep + '[ _ find-row-index ] map sift unique f assoc-like ; + +: initial-selected-indices ( table -- set ) { [ model>> value>> empty? not ] [ selection-required?>> ] - [ drop 0 ] + [ drop { 0 } unique ] } 1&& ; -: (update-selected-index) ( table -- n/f ) - [ selected-value>> value>> ] keep over - [ find-row-index ] [ 2drop f ] if ; - -: update-selected-index ( table -- n/f ) +: update-selected-indices ( table -- set ) { - [ (update-selected-index) ] - [ initial-selected-index ] + [ (update-selected-indices) ] + [ initial-selected-indices ] } 1|| ; M: table model-changed - nip dup update-selected-index { - [ >>selected-index f >>mouse-index drop ] - [ show-row-summary ] - [ drop update-selected-value ] + nip dup update-selected-indices { + [ >>selected-indices f >>mouse-index drop ] + [ multiple>single drop show-row-summary ] + [ drop update-selected ] [ drop relayout ] } 2cleave ; : thin-row-rect ( table row -- rect ) row-rect [ { 0 1 } v* ] change-dim ; +: scroll-to-row ( table n -- ) + dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ; + +: add-selected-row ( table n -- ) + [ scroll-to-row ] + [ add-selected-index relayout-1 ] 2bi ; + : (select-row) ( table n -- ) - [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] - [ >>selected-index relayout-1 ] + [ scroll-to-row ] + [ set-selected-index relayout-1 ] 2bi ; : mouse-row ( table -- n ) [ hand-rel second ] keep y>line ; -: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- ) +: if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- ) [ [ mouse-row ] keep 2dup valid-line? ] [ ] [ '[ nip @ ] ] tri* if ; inline +: (table-button-down) ( quot table -- ) + dup takes-focus?>> [ dup request-focus ] when swap + '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline + : table-button-down ( table -- ) - dup takes-focus?>> [ dup request-focus ] when - [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; + [ (select-row) ] swap (table-button-down) ; + +: continued-button-down ( table -- ) + dup multiple-selection?>> + [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ; + +: thru-button-down ( table -- ) + dup multiple-selection?>> [ + [ 2dup over selected-index (a,b) swap + [ swap add-selected-index drop ] curry each add-selected-row ] + swap (table-button-down) + ] [ table-button-down ] if ; PRIVATE> @@ -319,7 +386,7 @@ PRIVATE> : table-button-up ( table -- ) dup [ mouse-row ] keep valid-line? [ - dup row-action? [ row-action ] [ update-selected-value ] if + dup row-action? [ row-action ] [ update-selected ] if ] [ drop ] if ; PRIVATE> @@ -327,14 +394,14 @@ PRIVATE> : select-row ( table n -- ) over validate-line [ (select-row) ] - [ drop update-selected-value ] + [ drop update-selected ] [ show-row-summary ] 2tri ; > ] dip '[ _ + ] [ 0 ] if* select-row ; + [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ; : previous-row ( table -- ) -1 prev/next-row ; @@ -346,10 +413,10 @@ PRIVATE> 0 select-row ; : last-row ( table -- ) - dup control-value length 1- select-row ; + dup control-value length 1 - select-row ; : prev/next-page ( table n -- ) - over visible-lines 1- * prev/next-row ; + over visible-lines 1 - * prev/next-row ; : previous-page ( table -- ) -1 prev/next-page ; @@ -386,8 +453,11 @@ table "sundry" f { { mouse-enter show-mouse-help } { mouse-leave hide-mouse-help } { motion show-mouse-help } - { T{ button-down } table-button-down } + { T{ button-down f { S+ } 1 } thru-button-down } + { T{ button-down f { A+ } 1 } continued-button-down } { T{ button-up } table-button-up } + { T{ button-up f { S+ } } table-button-up } + { T{ button-down } table-button-down } { gain-focus focus-table } { lose-focus unfocus-table } { T{ drag } table-button-down } @@ -433,4 +503,4 @@ M: table viewport-column-header dup renderer>> column-titles [ ] [ drop f ] if ; -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor index 485015b898..042e2d3446 100644 --- a/basis/ui/pens/gradient/gradient.factor +++ b/basis/ui/pens/gradient/gradient.factor @@ -14,7 +14,7 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; :: gradient-vertices ( direction dim colors -- seq ) direction dim v* dim over v- swap - colors length dup 1- v/n [ v*n ] with map + colors length dup 1 - v/n [ v*n ] with map swap [ over v+ 2array ] curry map concat concat >float-array ; @@ -43,4 +43,4 @@ M: gradient draw-interior [ colors>> draw-gradient ] } cleave ; -M: gradient pen-background 2drop transparent ; \ No newline at end of file +M: gradient pen-background 2drop transparent ; diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index d56da86b86..d5e836044b 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -25,7 +25,7 @@ M: uniscribe-renderer draw-string ( font string -- ) M: uniscribe-renderer x>offset ( x font string -- n ) [ 2drop 0 ] [ - cached-script-string x>line-offset 0 = [ 1+ ] unless + cached-script-string x>line-offset 0 = [ 1 + ] unless ] if-empty ; M: uniscribe-renderer offset>x ( n font string -- x ) diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 024442a264..a4fda6600e 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -79,7 +79,7 @@ debugger "gestures" f { : com-help ( debugger -- ) error>> error-help-window ; -: com-edit ( debugger -- ) error>> (:edit) ; +: com-edit ( debugger -- ) error>> edit-error ; \ com-edit H{ { +listener+ t } } define-command diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor index 5040a13be2..ec96ac4078 100644 --- a/basis/ui/tools/error-list/error-list-docs.factor +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -12,8 +12,8 @@ $nl ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } - { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } + { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } } ; ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index e9d4b50bac..a1da59fe39 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -71,7 +71,7 @@ M: source-file-renderer filled-column drop 1 ; 60 >>min-cols 60 >>max-cols t >>selection-required? - error-list source-file>> >>selected-value ; + error-list source-file>> >>selection ; SINGLETON: error-renderer @@ -120,7 +120,7 @@ M: error-renderer column-alignment drop { 0 1 0 0 } ; 60 >>min-cols 60 >>max-cols t >>selection-required? - error-list error>> >>selected-value ; + error-list error>> >>selection ; TUPLE: error-display < track ; @@ -165,8 +165,8 @@ error-display "toolbar" f { { 5 5 } >>gap error-list f track-add error-list source-file-table>> "Source files" 1/4 track-add - error-list error-table>> "Errors" 1/2 track-add - error-list error-display>> "Details" 1/4 track-add + error-list error-table>> "Errors" 1/4 track-add + error-list error-display>> "Details" 1/2 track-add { 5 5 } 1 track-add ; M: error-list-gadget focusable-child* diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index 35fa5e3c17..b4a772dca5 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -57,7 +57,7 @@ M: object make-slot-descriptions make-mirror [ ] { } assoc>map ; M: hashtable make-slot-descriptions - call-next-method [ [ key-string>> ] compare ] sort ; + call-next-method [ key-string>> ] sort-with ; : ( model -- table ) [ make-slot-descriptions ] inspector-renderer
diff --git a/basis/ui/tools/listener/history/history.factor b/basis/ui/tools/listener/history/history.factor index 5e03ab21ad..dae9e26dc8 100644 --- a/basis/ui/tools/listener/history/history.factor +++ b/basis/ui/tools/listener/history/history.factor @@ -10,7 +10,7 @@ TUPLE: history document elements index ; V{ } clone 0 history boa ; : history-add ( history -- input ) - dup elements>> length 1+ >>index + dup elements>> length 1 + >>index [ document>> doc-string [ ] [ empty? ] bi ] keep '[ [ _ elements>> push ] keep ] unless ; @@ -32,7 +32,7 @@ TUPLE: history document elements index ; [ set-doc-string ] [ clear-undo drop ] 2bi ; : change-history-index ( history i -- ) - over elements>> length 1- + over elements>> length 1 - '[ _ + _ min 0 max ] change-index drop ; : history-recall ( history i -- ) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index e34e354a87..4b9a4a1ef3 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -170,7 +170,7 @@ M: interactor stream-read1 M: interactor dispose drop ; : go-to-error ( interactor error -- ) - [ line>> 1- ] [ column>> ] bi 2array + [ line>> 1 - ] [ column>> ] bi 2array over set-caret mark>caret ; @@ -444,4 +444,4 @@ M: listener-gadget graft* [ call-next-method ] [ restart-listener ] bi ; M: listener-gadget ungraft* - [ com-end ] [ call-next-method ] bi ; \ No newline at end of file + [ com-end ] [ call-next-method ] bi ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 8be357b409..c3fbdb88cd 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -147,7 +147,7 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; horizontal { 3 3 } >>gap profiler vocabs>> vocab-renderer - profiler vocab>> >>selected-value + profiler vocab>> >>selection 10 >>min-rows 10 >>max-rows "Vocabularies" @@ -164,11 +164,11 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; horizontal { 3 3 } >>gap profiler word-renderer - profiler generic>> >>selected-value + profiler generic>> >>selection "Generic words" 1/2 track-add profiler word-renderer - profiler class>> >>selected-value + profiler class>> >>selection "Classes" 1/2 track-add 1/2 track-add diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 9df084210d..11c2a48a2a 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -35,7 +35,7 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1+ tail-slice % ] 2bi + [ tuck children>> swap first 1 + tail-slice % ] 2bi ] make-node ] if ] if ; @@ -44,7 +44,7 @@ TUPLE: node value children ; traverse-step traverse-from-path ; : (traverse-middle) ( frompath topath gadget -- ) - [ first 1+ ] [ first ] [ children>> ] tri* % ; + [ first 1 + ] [ first ] [ children>> ] tri* % ; : traverse-post ( topath gadget -- ) traverse-step traverse-to-path ; @@ -94,4 +94,4 @@ M: array leaves* '[ _ leaves* ] each ; M: gadget leaves* conjoin ; -: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; \ No newline at end of file +: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 2486e701c0..aa3c549cf0 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -26,7 +26,7 @@ SYMBOL: windows #! etc. swap 2array windows get-global push windows get-global dup length 1 > - [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ; + [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ; : unregister-window ( handle -- ) windows [ [ first = not ] with filter ] change-global ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index ed96842c41..7c7b8a1f50 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -93,7 +93,7 @@ PRIVATE> : first-grapheme ( str -- i ) unclip-slice grapheme-class over [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop - nip swap length or 1+ ; + nip swap length or 1 + ; : first-grapheme-from ( start str -- i ) over tail-slice first-grapheme + ; @@ -192,13 +192,13 @@ to: word-table swap [ format/extended? not ] find-from drop ; : walk-up ( str i -- j ) - dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ; + dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ; : (walk-down) ( str i -- j ) swap [ format/extended? not ] find-last-from drop ; : walk-down ( str i -- j ) - dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ; + dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ; : word-break? ( str i table-entry -- ? ) { @@ -226,7 +226,7 @@ PRIVATE> : first-word ( str -- i ) [ unclip-slice word-break-prop over ] keep '[ swap _ word-break-next ] assoc-find 2drop - nip swap length or 1+ ; + nip swap length or 1 + ; : >words ( str -- words ) [ first-word ] >pieces ; @@ -234,7 +234,7 @@ PRIVATE> diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index cea880c0b0..ff2c808fde 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -27,7 +27,7 @@ IN: unicode.normalize.tests :: assert= ( test spec quot -- ) spec [ [ - [ 1- test nth ] bi@ + [ 1 - test nth ] bi@ [ 1quotation ] [ quot curry ] bi* unit-test ] with each ] assoc-each ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index aca96a5694..b1cba07511 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -108,7 +108,7 @@ HINTS: string-append string string ; ! Normalization -- Composition : initial-medial? ( str i -- ? ) - { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ; + { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ; : --final? ( str i -- ? ) 2 + swap ?nth final? ; @@ -124,7 +124,7 @@ HINTS: string-append string string ; : compose-jamo ( str i -- str i ) 2dup initial-medial? [ 2dup --final? [ imf, ] [ im, ] if - ] [ 2dup swap nth , 1+ ] if ; + ] [ 2dup swap nth , 1 + ] if ; : pass-combining ( str -- str i ) dup [ non-starter? not ] find drop @@ -136,7 +136,7 @@ TUPLE: compose-state i str char after last-class ; : get-str ( state i -- ch ) swap [ i>> + ] [ str>> ] bi ?nth ; inline : current ( state -- ch ) 0 get-str ; inline -: to ( state -- state ) [ 1+ ] change-i ; inline +: to ( state -- state ) [ 1 + ] change-i ; inline : push-after ( ch state -- state ) [ ?push ] change-after ; inline :: try-compose ( state new-char current-class -- state ) @@ -177,8 +177,8 @@ DEFER: compose-iter :: (compose) ( str i -- ) i str ?nth [ dup jamo? [ drop str i compose-jamo ] [ - i 1+ str ?nth combining-class - [ str i 1+ compose-combining ] [ , str i 1+ ] if + i 1 + str ?nth combining-class + [ str i 1 + compose-combining ] [ , str i 1 + ] if ] if (compose) ] when* ; inline recursive diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 91feae6471..eba0e4976f 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -64,7 +64,7 @@ PRIVATE> #! first group is -1337, legacy unix code -1337 NGROUPS_MAX [ 4 * ] keep [ getgrouplist io-error ] 2keep - [ 4 tail-slice ] [ *int 1- ] bi* >groups ; + [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; PRIVATE> diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index da8b1e63e3..131d8dda5d 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -80,7 +80,7 @@ CONSTANT: WNOWAIT HEX: 1000000 HEX: ff00 bitand -8 shift ; inline : WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline + HEX: 7f bitand 1 + -1 shift 0 > ; inline : WCOREFLAG ( -- value ) HEX: 80 ; inline diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor index bd4a2c1114..9e2c9539c6 100644 --- a/basis/unrolled-lists/unrolled-lists.factor +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -45,7 +45,7 @@ M: unrolled-list clear-deque : ( elt front -- node ) [ unroll-factor 0 - [ unroll-factor 1- swap set-nth ] keep f + [ unroll-factor 1 - swap set-nth ] keep f ] dip [ node boa dup ] keep dup [ (>>prev) ] [ 2drop ] if ; inline @@ -55,12 +55,12 @@ M: unrolled-list clear-deque ] [ dup front>> >>back ] if* drop ; inline : push-front/new ( elt list -- ) - unroll-factor 1- >>front-pos + unroll-factor 1 - >>front-pos [ ] change-front normalize-back ; inline : push-front/existing ( elt list front -- ) - [ [ 1- ] change-front-pos ] dip + [ [ 1 - ] change-front-pos ] dip [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline M: unrolled-list push-front* @@ -81,12 +81,12 @@ M: unrolled-list peek-front : pop-front/existing ( list front -- ) [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe - [ 1+ ] change-front-pos + [ 1 + ] change-front-pos drop ; inline M: unrolled-list pop-front* dup front>> [ empty-unrolled-list ] unless* - over front-pos>> unroll-factor 1- eq? + over front-pos>> unroll-factor 1 - eq? [ pop-front/new ] [ pop-front/existing ] if ; : ( elt back -- node ) @@ -106,8 +106,8 @@ M: unrolled-list pop-front* normalize-front ; inline : push-back/existing ( elt list back -- ) - [ [ 1+ ] change-back-pos ] dip - [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline + [ [ 1 + ] change-back-pos ] dip + [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline M: unrolled-list push-back* dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi @@ -116,7 +116,7 @@ M: unrolled-list push-back* M: unrolled-list peek-back dup back>> - [ [ back-pos>> 1- ] dip data>> nth-unsafe ] + [ [ back-pos>> 1 - ] dip data>> nth-unsafe ] [ empty-unrolled-list ] if* ; @@ -126,7 +126,7 @@ M: unrolled-list peek-back dup back>> [ normalize-front ] [ f >>front drop ] if ; inline : pop-back/existing ( list back -- ) - [ [ 1- ] change-back-pos ] dip + [ [ 1 - ] change-back-pos ] dip [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe drop ; inline diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 8e11dec431..f87c21d2ff 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -57,7 +57,7 @@ PRIVATE> 2dup length 2 - >= [ 2drop ] [ - [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + [ 1 + dup 2 + ] dip subseq hex> [ , ] when* ] if ; : url-decode-% ( index str -- index str ) @@ -70,7 +70,7 @@ PRIVATE> 2dup nth dup CHAR: % = [ drop url-decode-% [ 3 + ] dip ] [ - , [ 1+ ] dip + , [ 1 + ] dip ] if url-decode-iter ] if ; diff --git a/basis/values/values-tests.factor b/basis/values/values-tests.factor index 6ad5e7dee6..74c63e3d8f 100644 --- a/basis/values/values-tests.factor +++ b/basis/values/values-tests.factor @@ -5,5 +5,5 @@ VALUE: foo [ f ] [ foo ] unit-test [ ] [ 3 to: foo ] unit-test [ 3 ] [ foo ] unit-test -[ ] [ \ foo [ 1+ ] change-value ] unit-test +[ ] [ \ foo [ 1 + ] change-value ] unit-test [ 4 ] [ foo ] unit-test diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor index ae106cbf93..79870b483f 100644 --- a/basis/vlists/vlists.factor +++ b/basis/vlists/vlists.factor @@ -28,13 +28,13 @@ PRIVATE> M: vlist ppush >vlist< 2dup length = [ unshare ] unless - [ [ 1+ swap ] dip push ] keep vlist boa ; + [ [ 1 + swap ] dip push ] keep vlist boa ; ERROR: empty-vlist-error ; M: vlist ppop [ empty-vlist-error ] - [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ; + [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ; M: vlist clone [ length>> ] [ vector>> >vector ] bi vlist boa ; @@ -65,7 +65,7 @@ M: valist assoc-size vlist>> length 2/ ; : valist-at ( key i array -- value ? ) over 0 >= [ 3dup nth-unsafe = [ - [ 1+ ] dip nth-unsafe nip t + [ 1 + ] dip nth-unsafe nip t ] [ [ 2 - ] dip valist-at ] if diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index aa3e619660..b840b5ab9d 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -107,7 +107,8 @@ MEMO: all-vocabs-recursive ( -- assoc ) PRIVATE> : (load) ( prefix -- failures ) - child-vocabs-recursive no-roots no-prefixes + [ child-vocabs-recursive no-roots no-prefixes ] + [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi filter-unportable require-all ; diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 0e150ef07a..66bc277ef7 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -14,7 +14,7 @@ IN: vocabs.prettyprint [ swap DragQueryFile drop ] keep alien>u16-string diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index d180cb20e7..8bdbb9f1e9 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -713,11 +713,7 @@ ERROR: error-message-failed id ; GetLastError n>win32-error-string ; : (win32-error) ( n -- ) - dup zero? [ - drop - ] [ - win32-error-string throw - ] if ; + [ win32-error-string throw ] unless-zero ; : win32-error ( -- ) GetLastError (win32-error) ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index feb0bef7a8..7c5c26c2da 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -12,7 +12,7 @@ TUPLE: script-string font string metrics ssa size image disposed ; : line-offset>x ( n script-string -- x ) 2dup string>> length = [ ssa>> ! ssa - swap 1- ! icp + swap 1 - ! icp TRUE ! fTrailing ] [ ssa>> diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 7561d67482..5b2a0bcfb4 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -140,7 +140,7 @@ MACRO: interpolate-xml ( xml -- quot ) : number<-> ( doc -- dup ) 0 over [ dup var>> [ - over >>var [ 1+ ] dip + over >>var [ 1 + ] dip ] unless drop ] each-interpolated drop ; diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index 052cab15c2..b0dbdf22ac 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -13,7 +13,7 @@ IN: xml.tokenize swap [ version-1.0?>> over text? not ] [ check>> ] bi and [ - spot get [ 1+ ] change-column drop + spot get [ 1 + ] change-column drop disallowed-char ] [ drop ] if ] [ drop ] if* ; @@ -23,7 +23,7 @@ HINTS: assure-good-char { spot fixnum } ; : record ( spot char -- spot ) over char>> [ CHAR: \n = - [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if + [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if >>column ] [ drop ] if ; @@ -91,7 +91,7 @@ HINTS: next* { spot } ; : take-string ( match -- string ) dup length spot get '[ 2dup _ string-matches? ] take-until nip - dup length rot length 1- - head + dup length rot length 1 - - head get-char [ missing-close ] unless next ; : expect ( string -- ) diff --git a/basis/xmode/marker/state/state.factor b/basis/xmode/marker/state/state.factor index 44d3a0285e..3e7e697baa 100644 --- a/basis/xmode/marker/state/state.factor +++ b/basis/xmode/marker/state/state.factor @@ -28,7 +28,7 @@ SYMBOLS: line last-offset position context : next-token, ( len id -- ) [ position get 2dup + ] dip token, - position get + dup 1- position set last-offset set ; + position get + dup 1 - position set last-offset set ; : push-context ( rules -- ) context [ ] change ; diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 4a998a1ebb..dd70e45b6b 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -14,7 +14,7 @@ M: array resize resize-array ; M: object new-sequence drop 0 ; -M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 3c5ac31d23..9e36f9f00c 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,7 +1,7 @@ -IN: assocs.tests USING: kernel math namespaces make tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations specialized-arrays.double ; +IN: assocs.tests [ t ] [ H{ } dup assoc-subset? ] unit-test [ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test @@ -149,4 +149,4 @@ unit-test H{ { 1 3 } { 2 5 } } H{ { 1 7 } { 5 6 } } } assoc-refine -] unit-test \ No newline at end of file +] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index d94cd45c3d..13e17f90fd 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -425,8 +425,8 @@ tuple { "set-retainstack" "kernel" (( rs -- )) } { "set-callstack" "kernel" (( cs -- )) } { "exit" "system" (( n -- )) } - { "data-room" "memory" (( -- cards generations )) } - { "code-room" "memory" (( -- code-free code-total )) } + { "data-room" "memory" (( -- cards decks generations )) } + { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) } { "micros" "system" (( -- us )) } { "modify-code-heap" "compiler.units" (( alist -- )) } { "(dlopen)" "alien.libraries" (( path -- dll )) } diff --git a/core/bootstrap/syntax-docs.factor b/core/bootstrap/syntax-docs.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index 1c3e4d3bdf..a23e4ecd74 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,5 +1,5 @@ -IN: byte-arrays.tests USING: tools.test byte-arrays sequences kernel ; +IN: byte-arrays.tests [ 6 B{ 1 2 3 } ] [ 6 B{ 1 2 3 } resize-byte-array @@ -10,4 +10,4 @@ USING: tools.test byte-arrays sequences kernel ; [ -10 B{ } resize-byte-array ] must-fail -[ B{ 123 } ] [ 123 1byte-array ] unit-test \ No newline at end of file +[ B{ 123 } ] [ 123 1byte-array ] unit-test diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index bd7510c95f..fdf4ab6aca 100644 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,6 +1,6 @@ -IN: byte-vectors.tests USING: tools.test byte-vectors vectors sequences kernel prettyprint ; +IN: byte-vectors.tests [ 0 ] [ 123 length ] unit-test diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor deleted file mode 100644 index 8ba09d8e91..0000000000 --- a/core/checksums/checksums-tests.factor +++ /dev/null @@ -1,3 +0,0 @@ -IN: checksums.tests -USING: checksums tools.test ; - diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 0dd808c722..5fe46b532f 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -56,7 +56,7 @@ M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; : checksum-file ( path checksum -- value ) - #! normalize-path (file-reader) is equivalen to + #! normalize-path (file-reader) is equivalent to #! binary . We use the lower-level form #! so that we can move io.encodings.binary to basis/. [ normalize-path (file-reader) ] dip checksum-stream ; diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 2730e4683b..cbf6acdeed 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -12,7 +12,6 @@ ARTICLE: "class-operations" "Class operations" { $subsection classes-intersect? } { $subsection min-class } "Low-level implementation detail:" -{ $subsection class-types } { $subsection flatten-class } { $subsection flatten-builtin-class } { $subsection class-types } diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 6d221c1380..df4f8f2563 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -202,12 +202,14 @@ M: anonymous-complement (classes-intersect?) : class= ( first second -- ? ) [ class<= ] [ swap class<= ] 2bi and ; +ERROR: topological-sort-failed ; + : largest-class ( seq -- n elt ) dup [ [ class< ] with any? not ] curry find-last - [ "Topological sort failed" throw ] unless* ; + [ topological-sort-failed ] unless* ; : sort-classes ( seq -- newseq ) - [ [ name>> ] compare ] sort >vector + [ name>> ] sort-with >vector [ dup empty? not ] [ dup largest-class [ over delete-nth ] dip ] produce nip ; diff --git a/core/classes/builtin/builtin-tests.factor b/core/classes/builtin/builtin-tests.factor index 6f990d0d62..c6ce302c26 100755 --- a/core/classes/builtin/builtin-tests.factor +++ b/core/classes/builtin/builtin-tests.factor @@ -1,5 +1,5 @@ -IN: classes.builtin.tests USING: tools.test words sequences kernel memory accessors ; +IN: classes.builtin.tests [ f ] [ [ word? ] instances diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 32f7af8113..c74c8f3b50 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -50,13 +50,6 @@ M: builtin-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -M: anonymous-intersection (flatten-class) - participants>> [ flatten-builtin-class ] map - [ - builtins get sift [ (flatten-class) ] each - ] [ - [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each - ] if-empty ; +: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ; -M: anonymous-complement (flatten-class) - drop builtins get sift [ (flatten-class) ] each ; +M: anonymous-complement (flatten-class) drop full-cover ; diff --git a/core/classes/intersection/intersection-tests.factor b/core/classes/intersection/intersection-tests.factor new file mode 100644 index 0000000000..57e716fe44 --- /dev/null +++ b/core/classes/intersection/intersection-tests.factor @@ -0,0 +1,38 @@ +USING: kernel tools.test generic generic.standard ; +IN: classes.intersection.tests + +TUPLE: a ; +TUPLE: a1 < a ; TUPLE: a2 < a ; TUPLE: a3 < a2 ; +MIXIN: b +INSTANCE: a3 b +INSTANCE: a1 b +INTERSECTION: c a2 b ; + +GENERIC: x ( a -- b ) + +M: c x drop c ; +M: a x drop a ; + +[ a ] [ T{ a } x ] unit-test +[ a ] [ T{ a1 } x ] unit-test +[ a ] [ T{ a2 } x ] unit-test + +[ t ] [ T{ a3 } c? ] unit-test +[ t ] [ T{ a3 } \ x effective-method M\ c x eq? nip ] unit-test +[ c ] [ T{ a3 } x ] unit-test + +! More complex case +TUPLE: t1 ; +TUPLE: t2 < t1 ; TUPLE: t3 < t1 ; +TUPLE: t4 < t2 ; TUPLE: t5 < t2 ; + +UNION: m t4 t5 t3 ; +INTERSECTION: i t2 m ; + +GENERIC: g ( a -- b ) + +M: i g drop i ; +M: t4 g drop t4 ; + +[ t4 ] [ T{ t4 } g ] unit-test +[ i ] [ T{ t5 } g ] unit-test \ No newline at end of file diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 43018f6358..a0481a62a7 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words sequences kernel assocs combinators classes +USING: words accessors sequences kernel assocs combinators classes classes.algebra classes.builtin namespaces arrays math quotations ; IN: classes.intersection @@ -34,3 +34,15 @@ M: intersection-class instance? M: intersection-class (flatten-class) participants (flatten-class) ; + +! Horribly inefficient and inaccurate +: intersect-flattened-classes ( seq1 seq2 -- seq3 ) + ! Only keep those in seq1 that intersect something in seq2. + [ [ classes-intersect? ] with any? ] curry filter ; + +M: anonymous-intersection (flatten-class) + participants>> [ full-cover ] [ + [ flatten-class keys ] + [ intersect-flattened-classes ] map-reduce + [ dup set ] each + ] if-empty ; diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index 951608931b..dadfa59917 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -27,8 +27,18 @@ TUPLE: tuple-b < tuple-a ; PREDICATE: tuple-c < tuple-b slot>> ; -GENERIC: ptest ( tuple -- ) -M: tuple-a ptest drop ; -M: tuple-c ptest drop ; +GENERIC: ptest ( tuple -- x ) +M: tuple-a ptest drop tuple-a ; +M: tuple-c ptest drop tuple-c ; -[ ] [ tuple-b new ptest ] unit-test +[ tuple-a ] [ tuple-b new ptest ] unit-test +[ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test + +PREDICATE: tuple-d < tuple-a slot>> ; + +GENERIC: ptest' ( tuple -- x ) +M: tuple-a ptest' drop tuple-a ; +M: tuple-d ptest' drop tuple-d ; + +[ tuple-a ] [ tuple-b new ptest' ] unit-test +[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 72457ff974..4ee31936a9 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -1,7 +1,7 @@ -IN: classes.tuple.parser.tests USING: accessors classes.tuple.parser lexer words classes sequences math kernel slots tools.test parser compiler.units arrays classes.tuple eval multiline ; +IN: classes.tuple.parser.tests TUPLE: test-1 ; @@ -141,4 +141,4 @@ TUPLE: parsing-corner-case x ; "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" } "\n" join eval( -- tuple ) -] [ error>> unexpected-eof? ] must-fail-with \ No newline at end of file +] [ error>> unexpected-eof? ] must-fail-with diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 4c55001aa1..e915ca50fb 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -291,8 +291,7 @@ $nl { $subsection POSTPONE: SLOT: } "Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass." $nl -"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:" -{ $snippet "SLOT: length" "SLOT: underlying" } +"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots: " { $snippet "SLOT: length" } " and " { $snippet "SLOT: underlying" } ". " "An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations." $nl "For example, compare the definitions of the " { $link sbuf } " class," @@ -348,7 +347,7 @@ $nl { $list { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" } { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" } - { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" } + { { $snippet "\"layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" } } } ; HELP: define-tuple-predicate diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 8893db3929..7395014bed 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -434,7 +434,7 @@ HELP: cond>quot { $values { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } } { $description "Creates a quotation that when called, has the same effect as applying " { $link cond } " to " { $snippet "assoc" } "." $nl -"the generated quotation is more efficient than the naive implementation of " { $link cond } ", though, since it expands into a series of conditionals, and no iteration through " { $snippet "assoc" } " has to be performed." } +"The generated quotation is more efficient than the naive implementation of " { $link cond } ", though, since it expands into a series of conditionals, and no iteration through " { $snippet "assoc" } " has to be performed." } { $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ; HELP: case>quot diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 54037b899e..2bef1a568a 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -113,7 +113,7 @@ ERROR: no-case object ; ] if ; : ( initial length -- array ) - next-power-of-2 swap [ nip clone ] curry map ; + next-power-of-2 iota swap [ nip clone ] curry map ; : distribute-buckets ( alist initial quot -- buckets ) swapd [ [ dup first ] dip call 2array ] curry map diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 1abcba0720..ed7d433026 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -26,7 +26,7 @@ HELP: with-disposal HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error. Destructors are run in reverse order from the order in which they were registered." } { $notes "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:" { $code diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 3eb9273859..37d4fd1195 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,5 +1,5 @@ -IN: effects.tests USING: effects tools.test prettyprint accessors sequences ; +IN: effects.tests [ t ] [ 1 1 2 2 effect<= ] unit-test [ f ] [ 1 0 2 2 effect<= ] unit-test @@ -22,4 +22,4 @@ USING: effects tools.test prettyprint accessors sequences ; [ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test [ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test -[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test \ No newline at end of file +[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index c8ed6da2aa..66179c5e52 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -24,9 +24,11 @@ ERROR: bad-effect ; : parse-effect-tokens ( end -- tokens ) [ parse-effect-token dup ] curry [ ] produce nip ; +ERROR: stack-effect-omits-dashes effect ; + : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup - [ ] [ "Stack effect declaration must contain --" throw ] if ; + [ ] [ drop stack-effect-omits-dashes ] if ; : complete-effect ( -- effect ) "(" expect ")" parse-effect ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 73002a5d89..99c9783075 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -9,7 +9,7 @@ ARTICLE: "method-order" "Method precedence" $nl "Here is an example:" { $code - "GENERIC: explain" + "GENERIC: explain ( object -- )" "M: object explain drop \"an object\" print ;" "M: number explain drop \"a number\" print ;" "M: sequence explain drop \"a sequence\" print ;" @@ -17,7 +17,7 @@ $nl "The linear order is the following, from least-specific to most-specific:" { $code "{ object sequence number }" } "Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:" -{ $code "M: integer explain drop \"a sequence\" print ;" } +{ $code "M: integer explain drop \"an integer\" print ;" } "Now, the linear order is the following, from least-specific to most-specific:" { $code "{ object sequence number integer }" } "The " { $link order } " word can be useful to clarify method dispatch order:" diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor index 51e122431c..2279fd019c 100644 --- a/core/generic/math/math-tests.factor +++ b/core/generic/math/math-tests.factor @@ -1,5 +1,5 @@ -IN: generic.math.tests USING: generic.math math tools.test kernel ; +IN: generic.math.tests ! Test math-combination [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index 61ae4e1ba1..f59268b770 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -1,10 +1,10 @@ -IN: generic.single.tests USING: tools.test math math.functions math.constants generic.standard generic.single strings sequences arrays kernel accessors words specialized-arrays.double byte-arrays bit-arrays parser namespaces make quotations stack-checker vectors growable hashtables sbufs prettyprint byte-vectors bit-vectors specialized-vectors.double definitions generic sets graphs assocs grouping see eval ; +IN: generic.single.tests GENERIC: lo-tag-test ( obj -- obj' ) @@ -279,4 +279,4 @@ M: growable call-next-hooker call-next-method "growable " prepend ; ! Corner case [ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] [ error>> bad-dispatch-position? ] -must-fail-with \ No newline at end of file +must-fail-with diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 9a773f43a2..8a53368062 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -145,7 +145,7 @@ GENERIC: compile-engine ( engine -- obj ) default get [ swap update ] keep ; : lo-tag-number ( class -- n ) - "type" word-prop dup num-tags get member? + "type" word-prop dup num-tags get iota member? [ drop object tag-number ] unless ; M: tag-dispatch-engine compile-engine @@ -208,9 +208,11 @@ SYMBOL: predicate-engines : keep-going? ( assoc -- ? ) assumed get swap second first class<= ; +ERROR: unreachable ; + : prune-redundant-predicates ( assoc -- default assoc' ) { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup empty? ] [ drop [ unreachable ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } [ [ first second ] [ rest-slice ] bi ] diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 004b543c7f..54e58c0282 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,7 +1,7 @@ -IN: hashtables.tests USING: kernel math namespaces make tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; +IN: hashtables.tests [ f ] [ "hi" V{ 1 2 3 } at ] unit-test @@ -178,4 +178,4 @@ H{ } "x" set [ 1 ] [ 2 "h" get at ] unit-test ! Random test case -[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test \ No newline at end of file +[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index c3d7e8e89b..7d668eeab1 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.tests USING: tools.test io.backend kernel ; +IN: io.backend.tests [ ] [ "a" normalize-path drop ] unit-test diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index cf2781aac0..f5467daea6 100644 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,7 +10,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ; +: >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ; : >be ( x n -- byte-array ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 4846b06f32..a722655cad 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -73,14 +73,14 @@ M: utf8 encode-char PRIVATE> : code-point-length ( n -- x ) - dup zero? [ drop 1 ] [ + [ 1 ] [ log2 { { [ dup 0 6 between? ] [ 1 ] } { [ dup 7 10 between? ] [ 2 ] } { [ dup 11 15 between? ] [ 3 ] } { [ dup 16 20 between? ] [ 4 ] } } cond nip - ] if ; + ] if-zero ; : code-point-offsets ( string -- indices ) 0 [ code-point-length + ] accumulate swap suffix ; diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ac74e6b11e..70136f81eb 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -296,7 +296,7 @@ ARTICLE: "stdio-motivation" "Motivation for default streams" " 16 group" "] with-disposal" } -"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" +"This code is robust, however it is more complex than it needs to be. This is where the default stream words come in; using them, the above can be rewritten as follows:" { $code "USING: continuations kernel io io.files math.parser splitting ;" "\"data.txt\" utf8 [" @@ -338,7 +338,6 @@ $nl { $subsection write1 } { $subsection write } "If the default output stream is a character stream (" { $link stream-element-type } " outputs " { $link +character+ } "), lines of text can be written:" -{ $subsection readln } { $subsection print } { $subsection nl } { $subsection bl } diff --git a/core/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor index ad5453af61..e7b4338388 100644 --- a/core/io/streams/memory/memory.factor +++ b/core/io/streams/memory/memory.factor @@ -12,4 +12,4 @@ M: memory-stream stream-element-type drop +byte+ ; M: memory-stream stream-read1 [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] - [ [ 1+ ] change-index drop ] bi ; + [ [ 1 + ] change-index drop ] bi ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b617544084..4f4ad18837 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -803,7 +803,7 @@ ARTICLE: "looping-combinators" "Looping combinators" { $subsection until } "To execute one iteration of a loop, use the following word:" { $subsection do } -"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":" +"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns false on the first iteration. To ensure the body executes at least once, use " { $link do } ":" { $code "[ P ] [ Q ] do while" } diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor index b0c5d8cfda..5a39f24627 100644 --- a/core/layouts/layouts-tests.factor +++ b/core/layouts/layouts-tests.factor @@ -1,5 +1,5 @@ -IN: system.tests USING: layouts math tools.test ; +IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 99e6f05c6c..036c7d9721 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces math words strings -io vectors arrays math.parser combinators continuations ; +io vectors arrays math.parser combinators continuations +source-files.errors ; IN: lexer TUPLE: lexer text line line-text line-length column ; @@ -24,11 +25,8 @@ TUPLE: lexer text line line-text line-length column ; ERROR: unexpected want got ; -PREDICATE: unexpected-tab < unexpected - got>> CHAR: \t = ; - : forbid-tab ( c -- c ) - [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; + [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline : skip ( i seq ? -- n ) over length @@ -96,6 +94,9 @@ PREDICATE: unexpected-eof < unexpected TUPLE: lexer-error line column line-text error ; +M: lexer-error error-file error>> error-file ; +M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; + : ( msg -- error ) \ lexer-error new lexer get diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor index 6a77ef65fc..1fc59fce62 100644 --- a/core/make/make-docs.factor +++ b/core/make/make-docs.factor @@ -14,7 +14,7 @@ $nl $nl "On the other hand, using " { $link make } " instead of a single call to " { $link surround } " is overkill. The below headings summarize the most important cases where other idioms are more appropriate than " { $link make } "." { $heading "Make versus combinators" } -"Sometimes, usages of " { $link make } " are better expressed with " { $link "sequences-combinators" } ". For example, instead of calling a combinator with a quotation which executes " { $link , } " exactly once on each iteration, oftena combinator encapsulating that specific idiom exists and can be used." +"Sometimes, usages of " { $link make } " are better expressed with " { $link "sequences-combinators" } ". For example, instead of calling a combinator with a quotation which executes " { $link , } " exactly once on each iteration, often a combinator encapsulating that specific idiom exists and can be used." $nl "For example," { $code "[ [ 42 * , ] each ] { } make" } diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index bb7fc107b2..2b35ef76fd 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -121,14 +121,14 @@ M: bignum (log2) bignum-log2 ; over zero? [ 2drop 0.0 ] [ - dup zero? [ - 2drop 1/0. + [ + drop 1/0. ] [ pre-scale /f-loop over odd? [ zero? [ 1 + ] unless ] [ drop ] if post-scale - ] if + ] if-zero ] if ; inline M: bignum /f ( m n -- f ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 55a50cd5d7..c4a1bb4f34 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -213,9 +213,9 @@ HELP: sgn { $description "Outputs one of the following:" { $list - "-1 if " { $snippet "x" } " is negative" - "0 if " { $snippet "x" } " is equal to 0" - "1 if " { $snippet "x" } " is positive" + { "-1 if " { $snippet "x" } " is negative" } + { "0 if " { $snippet "x" } " is equal to 0" } + { "1 if " { $snippet "x" } " is positive" } } } ; diff --git a/core/math/math.factor b/core/math/math.factor index 28efbaa26e..8fa56e6e24 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -48,9 +48,11 @@ GENERIC: (log2) ( x -- n ) foldable PRIVATE> +ERROR: log2-expects-positive x ; + : log2 ( x -- n ) dup 0 <= [ - "log2 expects positive inputs" throw + log2-expects-positive ] [ (log2) ] if ; inline diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 368d060eb9..b2c2eeb973 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -109,7 +109,6 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection "order-specifiers" } "Utilities for comparing objects:" { $subsection after? } -{ $subsection after? } { $subsection before? } { $subsection after=? } { $subsection before=? } diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index cc01699bd4..21062baf4b 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -135,7 +135,7 @@ M: ratio >base [ dup 0 < negative? set abs 1 /mod - [ dup zero? [ drop "" ] [ (>base) sign append ] if ] + [ [ "" ] [ (>base) sign append ] if-zero ] [ [ numerator (>base) ] [ denominator (>base) ] bi diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index eb2968ece7..8ee2ca99c2 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -31,12 +31,12 @@ HELP: instances HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; -HELP: data-room ( -- cards generations ) -{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } +HELP: data-room ( -- cards decks generations ) +{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } } { $description "Queries the runtime for memory usage information." } ; -HELP: code-room ( -- code-free code-total ) -{ $values { "code-free" "bytes free in the code heap" } { "code-total" "total bytes in the code heap" } } +HELP: code-room ( -- code-total code-used code-free largest-free-block ) +{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } } { $description "Queries the runtime for memory usage information." } ; HELP: size ( obj -- n ) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index ec0810509b..146b1afdfa 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -54,7 +54,7 @@ $nl ARTICLE: "parsing-words" "Parsing words" "The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." $nl -"Parsing words are defined using the a defining word:" +"Parsing words are defined using the defining word:" { $subsection POSTPONE: SYNTAX: } "Parsing words have uppercase names by convention. Here is the simplest possible parsing word; it prints a greeting at parse time:" { $code "SYNTAX: HELLO \"Hello world\" print ;" } diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 71d42705a2..fbdd8268da 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -123,7 +123,48 @@ HELP: unless-empty } } ; -{ if-empty when-empty unless-empty } related-words +HELP: if-zero +{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." } +{ $example + "USING: kernel math prettyprint sequences ;" + "3 [ \"zero\" ] [ sq ] if-zero ." + "9" +} ; + +HELP: when-zero +{ $values + { "n" number } { "quot" "the first quotation of an " { $link if-zero } } } +{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:" + { $example + "USING: sequences prettyprint ;" + "0 [ 4 ] [ ] if-zero ." + "4" + } + { $example + "USING: sequences prettyprint ;" + "0 [ 4 ] when-zero ." + "4" + } +} ; + +HELP: unless-zero +{ $values + { "n" number } { "quot" "the second quotation of an " { $link if-empty } } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:" + { $example + "USING: sequences math prettyprint ;" + "3 [ ] [ sq ] if-empty ." + "9" + } + { $example + "USING: sequences math prettyprint ;" + "3 [ sq ] unless-zero ." + "9" + } +} ; HELP: delete-all { $values { "seq" "a resizable sequence" } } @@ -1214,7 +1255,7 @@ HELP: follow { $examples "Get random numbers until zero is reached:" { $unchecked-example "USING: random sequences prettyprint math ;" - "100 [ random dup zero? [ drop f ] when ] follow ." + "100 [ random [ f ] when-zero ] follow ." "{ 100 86 34 32 24 11 7 2 }" } } ; @@ -1393,6 +1434,18 @@ $nl $nl "More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; +ARTICLE: "sequences-if" "Control flow with sequences" +"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided." +$nl +"Checking if a sequence is empty:" +{ $subsection if-empty } +{ $subsection when-empty } +{ $subsection unless-empty } +"Checking if a number is zero:" +{ $subsection if-zero } +{ $subsection when-zero } +{ $subsection unless-zero } ; + ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection ?nth } "Concise way of extracting one of the first four elements:" @@ -1658,6 +1711,8 @@ $nl "Using sequences for looping:" { $subsection "sequences-integers" } { $subsection "math.ranges" } +"Using sequences for control flow:" +{ $subsection "sequences-if" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 17dbcf5c3c..aecc9e33d8 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -29,13 +29,27 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : empty? ( seq -- ? ) length 0 = ; inline + + : if-empty ( seq quot1 quot2 -- ) - [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline + [ dup empty? ] (if-empty) ; inline : when-empty ( seq quot -- ) [ ] if-empty ; inline : unless-empty ( seq quot -- ) [ ] swap if-empty ; inline +: if-zero ( n quot1 quot2 -- ) + [ dup zero? ] (if-empty) ; inline + +: when-zero ( n quot -- ) [ ] if-zero ; inline + +: unless-zero ( n quot -- ) [ ] swap if-zero ; inline + : delete-all ( seq -- ) 0 swap set-length ; : first ( seq -- first ) 0 swap nth ; inline @@ -267,9 +281,11 @@ INSTANCE: repetition immutable-sequence : reduce ( seq identity quot -- result ) swapd each ; inline +: map-integers ( len quot exemplar -- newseq ) + [ over ] dip [ [ collect ] keep ] new-like ; inline + : map-as ( seq quot exemplar -- newseq ) - [ over length ] dip [ [ map-into ] keep ] new-like ; inline + [ (each) ] dip map-integers ; inline : map ( seq quot -- newseq ) over map-as ; inline @@ -442,7 +461,7 @@ PRIVATE> [ -rot ] dip 2each ; inline : 2map-as ( seq1 seq2 quot exemplar -- newseq ) - [ (2each) ] dip map-as ; inline + [ (2each) ] dip map-integers ; inline : 2map ( seq1 seq2 quot -- newseq ) pick 2map-as ; inline @@ -454,7 +473,7 @@ PRIVATE> (3each) each ; inline : 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq ) - [ (3each) ] dip map-as ; inline + [ (3each) ] dip map-integers ; inline : 3map ( seq1 seq2 seq3 quot -- newseq ) [ pick ] dip swap 3map-as ; inline @@ -701,7 +720,7 @@ PRIVATE> 3tri ; : reverse-here ( seq -- ) - [ length 2/ ] [ length ] [ ] tri + [ length 2/ iota ] [ length ] [ ] tri [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; : reverse ( seq -- newseq ) @@ -805,14 +824,14 @@ PRIVATE> : start* ( subseq seq n -- i ) - pick length pick length swap - 1 + + pick length pick length swap - 1 + iota [ (start) ] find-from swap [ 3drop ] dip ; diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 1365e81524..81251d728f 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,6 +1,6 @@ -IN: slots.tests USING: math accessors slots strings generic.single kernel tools.test generic words parser eval math.functions ; +IN: slots.tests TUPLE: r/w-test foo ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 290ca1470c..c30c06a989 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -12,6 +12,8 @@ $nl "Sorting a sequence with a custom comparator:" { $subsection sort } "Sorting a sequence with common comparators:" +{ $subsection sort-with } +{ $subsection inv-sort-with } { $subsection natural-sort } { $subsection sort-keys } { $subsection sort-values } ; @@ -20,16 +22,24 @@ ABOUT: "sequences-sorting" HELP: sort { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements into a new array using a stable sort." } +{ $description "Sorts the elements of " { $snippet "seq" } " into a new array using a stable sort." } { $notes "The algorithm used is the merge sort." } ; +HELP: sort-with +{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } } +{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence." } ; + +HELP: inv-sort-with +{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } } +{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence and inverting the results." } ; + HELP: sort-keys { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing first elements of pairs using the " { $link <=> } " word." } ; +{ $description "Sorts the elements of " { $snippet "seq" } " comparing first elements of pairs using the " { $link <=> } " word." } ; HELP: sort-values { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing second elements of pairs using the " { $link <=> } " word." } ; +{ $description "Sorts the elements of " { $snippet "seq" } " comparing second elements of pairs using the " { $link <=> } " word." } ; HELP: natural-sort { $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } } @@ -43,4 +53,4 @@ HELP: midpoint@ { $values { "seq" "a sequence" } { "n" integer } } { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ; -{ <=> compare natural-sort sort-keys sort-values } related-words +{ <=> compare natural-sort sort-with inv-sort-with sort-keys sort-values } related-words diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 0c0951bbce..b8258b239b 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -155,8 +155,13 @@ PRIVATE> : natural-sort ( seq -- sortedseq ) [ <=> ] sort ; -: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ; +: sort-with ( seq quot -- sortedseq ) + [ compare ] curry sort ; inline +: inv-sort-with ( seq quot -- sortedseq ) + [ compare invert-comparison ] curry sort ; inline -: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; +: sort-keys ( seq -- sortedseq ) [ first ] sort-with ; + +: sort-values ( seq -- sortedseq ) [ second ] sort-with ; : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index f6f4f4825a..93078c162b 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -1,13 +1,25 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math.order sorting sequences definitions -namespaces arrays splitting io math.parser math init ; +namespaces arrays splitting io math.parser math init continuations ; IN: source-files.errors +GENERIC: error-file ( error -- file ) +GENERIC: error-line ( error -- line ) + +M: object error-file drop f ; +M: object error-line drop f ; + +M: condition error-file error>> error-file ; +M: condition error-line error>> error-line ; + TUPLE: source-file-error error asset file line# ; +M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ; +M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ; + : sort-errors ( errors -- alist ) - [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; : group-by-source-file ( errors -- assoc ) H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 5ec396e5ba..7aae30f20b 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -58,7 +58,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop [ [ swap subseq , ] 2keep 1 + swap (split) ] - [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive + [ swap [ tail ] unless-zero , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor old mode 100644 new mode 100755 diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 574f8afe81..806d09bf9e 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -276,6 +276,7 @@ HELP: parsing-word? HELP: define-declared { $values { "word" word } { "def" quotation } { "effect" effect } } { $description "Defines a word and declares its stack effect." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; HELP: define-temp @@ -311,4 +312,5 @@ HELP: make-inline HELP: define-inline { $values { "word" word } { "def" quotation } { "effect" effect } } { $description "Defines a word and makes it " { $link POSTPONE: inline } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "word" } ; diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index c659e109ce..cc09ad5281 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -57,7 +57,7 @@ t to: remove-hidden-solids? : with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline -: dimension ( array -- x ) length 1- ; inline +: dimension ( array -- x ) length 1 - ; inline : change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; inline @@ -99,7 +99,7 @@ TUPLE: light name { direction array } color ; : point-inside-or-on-halfspace? ( halfspace v -- ? ) position-point VERY-SMALL-NUM neg > ; : project-vector ( seq -- seq ) - pv> [ head ] [ 1+ tail ] 2bi append ; + pv> [ head ] [ 1 + tail ] 2bi append ; : get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ; @@ -336,7 +336,7 @@ TUPLE: solid dimension silhouettes : compute-adjacencies ( solid -- solid ) dup dimension>> [ >= ] curry [ keep swap ] curry MAX-FACE-PER-CORNER swap - [ [ test-faces-combinaisons ] 2keep 1- ] while drop ; + [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ; : find-adjacencies ( solid -- solid ) erase-old-adjacencies @@ -435,7 +435,7 @@ TUPLE: space name dimension solids ambient-color lights ; [ [ non-empty-solid? ] filter ] change-solids ; : projected-space ( space solids -- space ) - swap dimension>> 1- + swap dimension>> 1 - swap >>dimension swap >>solids ; : get-silhouette ( solid -- silhouette ) diff --git a/extra/adsoda/combinators/combinators.factor b/extra/adsoda/combinators/combinators.factor index 4e4bbff72d..d00eebc976 100755 --- a/extra/adsoda/combinators/combinators.factor +++ b/extra/adsoda/combinators/combinators.factor @@ -13,7 +13,7 @@ IN: adsoda.combinators ! { [ dup 0 = ] [ 2drop { { } } ] } ! { [ over empty? ] [ 2drop { } ] } ! { [ t ] [ -! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ] +! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ] ! [ (combinations) ] 2bi append ! ] } ! } cond ; @@ -26,7 +26,7 @@ IN: adsoda.combinators { [ over 1 = ] [ 3drop columnize ] } { [ over 0 = ] [ 2drop 2drop { } ] } { [ 2dup < ] [ 2drop [ 1 cut ] dip - [ 1- among [ append ] with map ] + [ 1 - among [ append ] with map ] [ among append ] 2bi ] } { [ 2dup = ] [ 3drop 1array ] } diff --git a/extra/adsoda/solution2/solution2.factor b/extra/adsoda/solution2/solution2.factor index 3e0648128d..fa73120df3 100755 --- a/extra/adsoda/solution2/solution2.factor +++ b/extra/adsoda/solution2/solution2.factor @@ -66,7 +66,7 @@ SYMBOL: matrix : do-row ( exchange-with row# -- ) [ exchange-rows ] keep [ first-col ] keep - dup 1+ rows-from clear-col ; + dup 1 + rows-from clear-col ; : find-row ( row# quot -- i elt ) [ rows-from ] dip find ; inline @@ -76,8 +76,8 @@ SYMBOL: matrix : (echelon) ( col# row# -- ) over cols < over rows < and [ - 2dup pivot-row [ over do-row 1+ ] when* - [ 1+ ] dip (echelon) + 2dup pivot-row [ over do-row 1 + ] when* + [ 1 + ] dip (echelon) ] [ 2drop ] if ; diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor index d5a13e48d8..48fd281c6c 100644 --- a/extra/annotations/annotations-tests.factor +++ b/extra/annotations/annotations-tests.factor @@ -10,7 +10,7 @@ IN: annotations.tests : four ( -- x ) !BROKEN this code is broken - 2 2 + 1+ ; + 2 2 + 1 + ; : five ( -- x ) !TODO return 5 diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index 6b3fd41575..14ebcb1c5b 100755 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -15,7 +15,7 @@ IN: benchmark.beust2 remaining 1 <= [ listener call f ] [ - remaining 1- + remaining 1 - 0 value' 10 * used mask bitor @@ -29,12 +29,12 @@ IN: benchmark.beust2 ] any? ; inline recursive :: count-numbers ( max listener -- ) - 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ; + 10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ; inline :: beust ( -- ) [let | i! [ 0 ] | - 5000000000 [ i 1+ i! ] count-numbers + 5000000000 [ i 1 + i! ] count-numbers i number>string " unique numbers." append print ] ; diff --git a/extra/benchmark/chameneos-redux/authors.txt b/extra/benchmark/chameneos-redux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/benchmark/chameneos-redux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/benchmark/chameneos-redux/chameneos-redux.factor b/extra/benchmark/chameneos-redux/chameneos-redux.factor new file mode 100644 index 0000000000..afd2f8830a --- /dev/null +++ b/extra/benchmark/chameneos-redux/chameneos-redux.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +concurrency.mailboxes fry io kernel make math math.parser +math.text.english sequences threads ; +IN: benchmark.chameneos-redux + +SYMBOLS: red yellow blue ; + +ERROR: bad-color-pair pair ; + +TUPLE: creature n color count self-count mailbox ; + +TUPLE: meeting-place count mailbox ; + +: ( count -- meeting-place ) + meeting-place new + swap >>count + >>mailbox ; + +: ( n color -- creature ) + creature new + swap >>color + swap >>n + 0 >>count + 0 >>self-count + >>mailbox ; + +: make-creatures ( colors -- seq ) + [ length iota ] [ ] bi [ ] 2map ; + +: complement-color ( color1 color2 -- color3 ) + 2dup = [ drop ] [ + 2array { + { { red yellow } [ blue ] } + { { red blue } [ yellow ] } + { { yellow red } [ blue ] } + { { yellow blue } [ red ] } + { { blue red } [ yellow ] } + { { blue yellow } [ red ] } + [ bad-color-pair ] + } case + ] if ; + +: color-string ( color1 color2 -- string ) + [ + [ [ name>> ] bi@ " + " glue % " -> " % ] + [ complement-color name>> % ] 2bi + ] "" make ; + +: print-color-table ( -- ) + { blue red yellow } dup + '[ _ '[ color-string print ] with each ] each ; + +: try-meet ( meeting-place creature -- ) + over count>> 0 < [ + 2drop + ] [ + [ swap mailbox>> mailbox-put ] + [ nip mailbox>> mailbox-get drop ] + [ try-meet ] 2tri + ] if ; + +: creature-meeting ( seq -- ) + first2 { + [ [ [ 1 + ] change-count ] bi@ 2drop ] + [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ] + [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ] + [ [ mailbox>> f swap mailbox-put ] bi@ ] + } 2cleave ; + +: run-meeting-place ( meeting-place -- ) + [ 1 - ] change-count + dup count>> 0 < [ + mailbox>> mailbox-get-all + [ f swap mailbox>> mailbox-put ] each + ] [ + [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ] + [ run-meeting-place ] bi + ] if ; + +: number>chameneos-string ( n -- string ) + number>string string>digits [ number>text ] { } map-as " " join ; + +: chameneos-redux ( n colors -- ) + [ ] [ make-creatures ] bi* + { + [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ] + [ [ '[ _ _ try-meet ] in-thread ] with each ] + [ drop run-meeting-place ] + + [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ] + [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ] + } 2cleave ; + +! 6000000 for shootout, too slow right now + +: chameneos-redux-main ( -- ) + print-color-table + 60000 [ + { blue red yellow } chameneos-redux + ] [ + { blue red yellow red yellow blue red yellow red blue } chameneos-redux + ] bi ; + +MAIN: chameneos-redux-main diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor index a69c53852d..63e635f3de 100644 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -7,7 +7,7 @@ IN: benchmark.fannkuch : count ( quot: ( -- ? ) -- n ) #! Call quot until it returns false, return number of times #! it was true - [ 0 ] dip '[ _ dip swap [ [ 1+ ] when ] keep ] loop ; inline + [ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline : count-flips ( perm -- flip# ) '[ @@ -19,12 +19,12 @@ IN: benchmark.fannkuch [ CHAR: 0 + write1 ] each nl ; inline : fannkuch-step ( counter max-flips perm -- counter max-flips ) - pick 30 < [ [ 1+ ] [ ] [ dup write-permutation ] tri* ] when + pick 30 < [ [ 1 + ] [ ] [ dup write-permutation ] tri* ] when count-flips max ; inline : fannkuch ( n -- ) [ - [ 0 0 ] dip [ 1+ ] B{ } map-as + [ 0 0 ] dip [ 1 + ] B{ } map-as [ fannkuch-step ] each-permutation nip ] keep "Pfannkuchen(" write pprint ") = " write . ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index f457b90c30..c1d554a5a3 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -63,7 +63,7 @@ CONSTANT: homo-sapiens :: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip - dup zero? [ drop ] quot if ; inline + quot unless-zero ; inline : write-random-fasta ( seed n chars floats desc id -- seed ) write-description diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor index c988e5722e..fa49503797 100644 --- a/extra/benchmark/fib4/fib4.factor +++ b/extra/benchmark/fib4/fib4.factor @@ -9,10 +9,10 @@ C: box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup tuple-fib swap - i>> 1- + i>> 1 - tuple-fib swap i>> swap i>> + ] if ; inline recursive diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index f81b6a21a2..70ce975974 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,10 +1,10 @@ -IN: benchmark.fib6 USING: math kernel alien ; +IN: benchmark.fib6 : fib ( x -- y ) "int" { "int" } "cdecl" [ dup 1 <= [ drop 1 ] [ - 1- dup fib swap 1- fib + + 1 - dup fib swap 1- fib + ] if ] alien-callback "int" { "int" } "cdecl" alien-indirect ; diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor index d201a08ecf..8b0a3e6a43 100644 --- a/extra/benchmark/gc1/gc1.factor +++ b/extra/benchmark/gc1/gc1.factor @@ -3,6 +3,6 @@ USING: math sequences kernel ; IN: benchmark.gc1 -: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ; +: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ; -MAIN: gc1 \ No newline at end of file +MAIN: gc1 diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 99b0ee15f4..fb4f17cca5 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -23,12 +23,12 @@ IN: benchmark.knucleotide : tally ( x exemplar -- b ) clone tuck [ - [ [ 1+ ] [ 1 ] if* ] change-at + [ [ 1 + ] [ 1 ] if* ] change-at ] curry each ; : small-groups ( x n -- b ) swap - [ length swap - 1+ ] 2keep + [ length swap - 1 + ] 2keep [ [ over + ] dip subseq ] 2curry map ; : handle-table ( inputs n -- ) diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor index 9e0f2472e2..0300538ce1 100644 --- a/extra/benchmark/mandel/colors/colors.factor +++ b/extra/benchmark/mandel/colors/colors.factor @@ -12,7 +12,7 @@ CONSTANT: val 0.85 : ( nb-cols -- map ) dup [ - 360 * swap 1+ / sat val + 360 * swap 1 + / sat val 1 >rgba scale-rgb ] with map ; diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index f72ceb4629..983da88821 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -59,7 +59,7 @@ TUPLE: nbody-system { bodies array read-only } ; :: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- ) bodies [| body i | body each-quot call - bodies i 1+ tail-slice [ + bodies i 1 + tail-slice [ body pair-quot call ] each ] each-index ; inline diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index 246a962a55..9ccc2d8616 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -1,6 +1,6 @@ -IN: benchmark.nsieve-bits USING: math math.parser sequences sequences.private kernel bit-arrays make io ; +IN: benchmark.nsieve-bits : clear-flags ( step i seq -- ) 2dup length >= [ @@ -13,14 +13,14 @@ bit-arrays make io ; 2dup length < [ 2dup nth-unsafe [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve-bits) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve-bits) ] [ 2drop ] if ; inline recursive : nsieve-bits ( m -- count ) - 0 2 rot 1+ dup set-bits (nsieve-bits) ; + 0 2 rot 1 + dup set-bits (nsieve-bits) ; : nsieve-bits. ( m -- ) [ "Primes up to " % dup # " " % nsieve-bits # ] "" make @@ -28,7 +28,7 @@ bit-arrays make io ; : nsieve-bits-main ( n -- ) dup 2^ 10000 * nsieve-bits. - dup 1- 2^ 10000 * nsieve-bits. + dup 1 - 2^ 10000 * nsieve-bits. 2 - 2^ 10000 * nsieve-bits. ; : nsieve-bits-main* ( -- ) 11 nsieve-bits-main ; diff --git a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor index bbeccf750b..15c0f9ee0b 100644 --- a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor +++ b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor @@ -13,14 +13,14 @@ byte-arrays make io ; 2dup length < [ 2dup nth-unsafe 0 > [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve) ] [ 2drop ] if ; inline recursive : nsieve ( m -- count ) - 0 2 rot 1+ dup [ drop 1 ] change-each (nsieve) ; + 0 2 rot 1 + dup [ drop 1 ] change-each (nsieve) ; : nsieve. ( m -- ) [ "Primes up to " % dup # " " % nsieve # ] "" make print ; diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor index 6fbc144e80..646c98f3a4 100644 --- a/extra/benchmark/nsieve/nsieve.factor +++ b/extra/benchmark/nsieve/nsieve.factor @@ -1,6 +1,6 @@ -IN: benchmark.nsieve USING: math math.parser sequences sequences.private kernel arrays make io ; +IN: benchmark.nsieve : clear-flags ( step i seq -- ) 2dup length >= [ @@ -13,14 +13,14 @@ arrays make io ; 2dup length < [ 2dup nth-unsafe [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve) ] [ 2drop ] if ; inline recursive : nsieve ( m -- count ) - 0 2 rot 1+ t (nsieve) ; + 0 2 rot 1 + t (nsieve) ; : nsieve. ( m -- ) [ "Primes up to " % dup # " " % nsieve # ] "" make print ; diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor index 7c7c68b12d..023f5de5c2 100644 --- a/extra/benchmark/partial-sums/partial-sums.factor +++ b/extra/benchmark/partial-sums/partial-sums.factor @@ -5,21 +5,21 @@ combinators hints fry namespaces sequences ; IN: benchmark.partial-sums ! Helper words -: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline +: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline : summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline : cube ( x -- y ) dup dup * * ; inline -: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline +: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline ! The functions -: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline +: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1 - ^ ] summing-floats ; inline : k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline -: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline +: 1/k(k+1) ( n -- y ) [ dup 1 + * recip ] summing-floats ; inline : flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline : cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline : harmonic ( n -- y ) [ recip ] summing-floats ; inline : riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline : alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline -: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline +: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1 - ] bi / ] summing-integers ; inline : partial-sums ( n -- results ) [ diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 642b3dbb93..25915404be 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -78,6 +78,8 @@ C: sphere M: sphere intersect-scene ( hit ray sphere -- hit ) [ [ sphere-n normalize ] keep nip ] if-ray-sphere ; +HINTS: M\ sphere intersect-scene { hit ray sphere } ; + TUPLE: group < sphere { objs array read-only } ; : ( objs bound -- group ) @@ -89,6 +91,8 @@ TUPLE: group < sphere { objs array read-only } ; M: group intersect-scene ( hit ray group -- hit ) [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ; +HINTS: M\ group intersect-scene { hit ray group } ; + CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. } : initial-intersect ( ray scene -- hit ) diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index 128ec571f2..219c73ae0a 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -7,18 +7,18 @@ IN: benchmark.recursive : ack ( m n -- x ) { - { [ over zero? ] [ nip 1+ ] } - { [ dup zero? ] [ drop 1- 1 ack ] } - [ [ drop 1- ] [ 1- ack ] 2bi ack ] + { [ over zero? ] [ nip 1 + ] } + { [ dup zero? ] [ drop 1 - 1 ack ] } + [ [ drop 1 - ] [ 1 - ack ] 2bi ack ] } cond ; inline recursive : tak ( x y z -- t ) 2over <= [ 2nip ] [ - [ rot 1- -rot tak ] - [ -rot 1- -rot tak ] - [ 1- -rot tak ] + [ rot 1 - -rot tak ] + [ -rot 1 - -rot tak ] + [ 1 - -rot tak ] 3tri tak ] if ; inline recursive @@ -26,7 +26,7 @@ IN: benchmark.recursive : recursive ( n -- ) [ 3 swap ack . flush ] [ 27.0 + fib . flush ] - [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri + [ 1 - [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri 3 fib . flush 3.0 2.0 1.0 tak . flush ; diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor index 483311d4f4..bd9a7139b3 100644 --- a/extra/benchmark/tuple-arrays/tuple-arrays.factor +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -11,10 +11,10 @@ TUPLE-ARRAY: point : tuple-array-benchmark ( -- ) 100 [ drop 5000 [ - [ 1+ ] change-x - [ 1- ] change-y - [ 1+ 2 / ] change-z + [ 1 + ] change-x + [ 1 - ] change-y + [ 1 + 2 / ] change-z ] map [ z>> ] sigma ] sigma . ; -MAIN: tuple-array-benchmark \ No newline at end of file +MAIN: tuple-array-benchmark diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor new file mode 100644 index 0000000000..ca57de822f --- /dev/null +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -0,0 +1,95 @@ +! Copyright (C) Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.accessors alien.c-types alien.syntax byte-arrays +destructors generalizations hints kernel libc locals math math.order +sequences sequences.private ; +IN: benchmark.yuv-to-rgb + +C-STRUCT: yuv_buffer + { "int" "y_width" } + { "int" "y_height" } + { "int" "y_stride" } + { "int" "uv_width" } + { "int" "uv_height" } + { "int" "uv_stride" } + { "void*" "y" } + { "void*" "u" } + { "void*" "v" } ; + +:: fake-data ( -- rgb yuv ) + [let* | w [ 1600 ] + h [ 1200 ] + buffer [ "yuv_buffer" ] + rgb [ w h * 3 * ] | + w buffer set-yuv_buffer-y_width + h buffer set-yuv_buffer-y_height + h buffer set-yuv_buffer-uv_height + w buffer set-yuv_buffer-y_stride + w buffer set-yuv_buffer-uv_stride + w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y + w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u + w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v + rgb buffer + ] ; + +: clamp ( n -- n ) + 255 min 0 max ; inline + +: stride ( line yuv -- uvy yy ) + [ yuv_buffer-uv_stride swap 2/ * >fixnum ] + [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline + +: compute-y ( yuv uvy yy x -- y ) + + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline + +: compute-v ( yuv uvy yy x -- v ) + nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline + +: compute-u ( yuv uvy yy x -- v ) + nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline + +:: compute-yuv ( yuv uvy yy x -- y u v ) + yuv uvy yy x compute-y + yuv uvy yy x compute-u + yuv uvy yy x compute-v ; inline + +: compute-blue ( y u v -- b ) + drop 516 * 128 + swap 298 * + -8 shift clamp ; inline + +: compute-green ( y u v -- g ) + [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift clamp ; + inline + +: compute-red ( y u v -- g ) + nip 409 * swap 298 * + 128 + -8 shift clamp ; inline + +: compute-rgb ( y u v -- b g r ) + [ compute-blue ] [ compute-green ] [ compute-red ] 3tri ; + inline + +: store-rgb ( index rgb b g r -- index ) + [ pick 0 + pick set-nth-unsafe ] + [ pick 1 + pick set-nth-unsafe ] + [ pick 2 + pick set-nth-unsafe ] tri* + drop ; inline + +: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index ) + compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline + +: yuv>rgb-row ( index rgb yuv y -- index ) + over stride + pick yuv_buffer-y_width >fixnum + [ yuv>rgb-pixel ] with with with with each ; inline + +: yuv>rgb ( rgb yuv -- ) + [ 0 ] 2dip + dup yuv_buffer-y_height >fixnum + [ yuv>rgb-row ] with with each + drop ; + +HINTS: yuv>rgb byte-array byte-array ; + +: yuv>rgb-benchmark ( -- ) + [ fake-data yuv>rgb ] with-destructors ; + +MAIN: yuv>rgb-benchmark diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 620f737fe3..b7400c4acb 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -11,7 +11,7 @@ TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; : next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi - 1+ swap length mod + 1 + swap length mod >>draw-n relayout-1 ; : make-draws ( gadget -- draw-seq ) diff --git a/extra/c/lexer/authors.txt b/extra/c/lexer/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/c/lexer/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor new file mode 100644 index 0000000000..c972b8816c --- /dev/null +++ b/extra/c/lexer/lexer-tests.factor @@ -0,0 +1,103 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors c.lexer kernel sequence-parser tools.test ; +IN: c.lexer.tests + +[ 36 ] +[ + " //jofiejoe\n //eoieow\n/*asdf*/\n " + skip-whitespace/comments n>> +] unit-test + +[ f "33asdf" ] +[ "33asdf" [ take-c-identifier ] [ take-rest ] bi ] unit-test + +[ "asdf" ] +[ "asdf" take-c-identifier ] unit-test + +[ "_asdf" ] +[ "_asdf" take-c-identifier ] unit-test + +[ "_asdf400" ] +[ "_asdf400" take-c-identifier ] unit-test + +[ "asdfasdf" ] [ + "/*asdfasdf*/" take-c-comment +] unit-test + +[ "k" ] [ + "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "omg" ] [ + "//asdfasdf\nomg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + +[ "omg" ] [ + "omg" + [ take-c++-comment drop ] [ take-rest ] bi +] unit-test + +[ "/*asdfasdf" ] [ + "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "asdf" "eoieoei" ] [ + "//asdf\neoieoei" + [ take-c++-comment ] [ take-rest ] bi +] unit-test + +[ f ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi +] unit-test + +[ "abc\\\"def" ] +[ + "\"abc\\\"def\" asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "asdf" ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ skip-whitespace "asdf" take-sequence ] bi +] unit-test + +[ f ] +[ + "\"abc asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "\"abc" ] +[ + "\"abc asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ "\"abc" take-sequence ] bi +] unit-test + +[ "c" ] +[ "c" take-token ] unit-test + +[ f ] +[ "" take-token ] unit-test + +[ "abcd e \\\"f g" ] +[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test + +[ "123" ] +[ "123jjj" take-c-integer ] unit-test + +[ "123uLL" ] +[ "123uLL" take-c-integer ] unit-test + +[ "123ull" ] +[ "123ull" take-c-integer ] unit-test + +[ "123u" ] +[ "123u" take-c-integer ] unit-test + diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor new file mode 100644 index 0000000000..962407e6ec --- /dev/null +++ b/extra/c/lexer/lexer.factor @@ -0,0 +1,123 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.short-circuit +generalizations kernel locals math.order math.ranges +sequence-parser sequences sorting.functor sorting.slots +unicode.categories ; +IN: c.lexer + +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + +: take-c++-comment ( sequence-parser -- seq/f ) + [ + dup "//" take-sequence [ + [ + [ + { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| + ] take-until + ] [ + advance drop + ] bi + ] [ + drop f + ] if + ] with-sequence-parser ; + +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace-eol + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + +:: take-quoted-string ( sequence-parser escape-char quote-char -- string ) + sequence-parser n>> :> start-n + sequence-parser advance + [ + { + [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] + [ current quote-char = not ] + } 1|| + ] take-while :> string + sequence-parser current quote-char = [ + sequence-parser advance* string + ] [ + start-n sequence-parser (>>n) f + ] if ; + +: (take-token) ( sequence-parser -- string ) + skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; + +:: take-token* ( sequence-parser escape-char quote-char -- string/f ) + sequence-parser skip-whitespace + dup current { + { quote-char [ escape-char quote-char take-quoted-string ] } + { f [ drop f ] } + [ drop (take-token) ] + } case ; + +: take-token ( sequence-parser -- string/f ) + CHAR: \ CHAR: " take-token* ; + +: c-identifier-begin? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + { CHAR: _ } 3append member? ; + +: c-identifier-ch? ( ch -- ? ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 0 CHAR: 9 [a,b] + { CHAR: _ } 4 nappend member? ; + +: (take-c-identifier) ( sequence-parser -- string/f ) + dup current c-identifier-begin? [ + [ current c-identifier-ch? ] take-while + ] [ + drop f + ] if ; + +: take-c-identifier ( sequence-parser -- string/f ) + [ (take-c-identifier) ] with-sequence-parser ; + +<< "length" [ length ] define-sorting >> + +: sort-tokens ( seq -- seq' ) + { length>=< <=> } sort-by ; + +: take-c-integer ( sequence-parser -- string/f ) + [ + dup take-integer [ + swap + { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" } + take-longest [ append ] when* + ] [ + drop f + ] if* + ] with-sequence-parser ; + +CONSTANT: c-punctuators + { + "[" "]" "(" ")" "{" "}" "." "->" + "++" "--" "&" "*" "+" "-" "~" "!" + "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" + "?" ":" ";" "..." + "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" + "," "#" "##" + "<:" ":>" "<%" "%>" "%:" "%:%:" + } + +: take-c-punctuator ( sequence-parser -- string/f ) + c-punctuators take-longest ; diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f787befc31..3018fa7a24 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -4,7 +4,7 @@ USING: sequence-parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories -combinators.short-circuit ; +combinators.short-circuit c.lexer ; IN: c.preprocessor : initial-library-paths ( -- seq ) diff --git a/extra/central/central-tests.factor b/extra/central/central-tests.factor index 3dbcbf32fc..17c5ee901f 100644 --- a/extra/central/central-tests.factor +++ b/extra/central/central-tests.factor @@ -9,11 +9,11 @@ CENTRAL: test-central TUPLE: test-disp-cent value disposed ; ! A phony destructor that adds 1 to the value so we can make sure it got called. -M: test-disp-cent dispose* dup value>> 1+ >>value drop ; +M: test-disp-cent dispose* dup value>> 1 + >>value drop ; DISPOSABLE-CENTRAL: t-d-c : test-t-d-c ( -- n ) test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ; -[ 4 ] [ test-t-d-c ] unit-test \ No newline at end of file +[ 4 ] [ test-t-d-c ] unit-test diff --git a/extra/closures/closures.factor b/extra/closures/closures.factor new file mode 100644 index 0000000000..79fcf7564e --- /dev/null +++ b/extra/closures/closures.factor @@ -0,0 +1,13 @@ +USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ; +IN: closures +SYMBOL: | + +! Selective Binding +: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ; +SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ; +! Common ones +SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ; + +! Namespace Binding +: bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ; +SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ; \ No newline at end of file diff --git a/extra/compiler/cfg/graphviz/graphviz.factor b/extra/compiler/cfg/graphviz/graphviz.factor deleted file mode 100644 index 0aade1301f..0000000000 --- a/extra/compiler/cfg/graphviz/graphviz.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license -USING: accessors compiler.cfg.rpo compiler.cfg.dominance -compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer -io io.encodings.ascii io.files io.files.unique io.launcher kernel -math.parser sequences assocs arrays make namespaces ; -IN: compiler.cfg.graphviz - -: render-graph ( edges -- ) - "cfg" "dot" make-unique-file - [ - ascii [ - "digraph CFG {" print - [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each - "}" print - ] with-file-writer - ] - [ { "dot" "-Tpng" "-O" } swap suffix try-process ] - [ ".png" append { "open" } swap suffix try-process ] - tri ; - -: cfg-edges ( cfg -- edges ) - [ - [ - dup successors>> [ - 2array , - ] with each - ] each-basic-block - ] { } make ; - -: render-cfg ( cfg -- ) cfg-edges render-graph ; - -: dom-edges ( cfg -- edges ) - [ - compute-predecessors - compute-dominance - dom-childrens get [ - [ - 2array , - ] with each - ] assoc-each - ] { } make ; - -: render-dom ( cfg -- ) dom-edges render-graph ; \ No newline at end of file diff --git a/extra/compiler/graphviz/graphviz.factor b/extra/compiler/graphviz/graphviz.factor new file mode 100644 index 0000000000..9823f93d4e --- /dev/null +++ b/extra/compiler/graphviz/graphviz.factor @@ -0,0 +1,138 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license +USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo +compiler.cfg.dominance compiler.cfg.dominance.private +compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer +compiler.cfg.utilities compiler.tree.recursive images.viewer +images.png io io.encodings.ascii io.files io.files.unique io.launcher +kernel math.parser sequences assocs arrays make math namespaces +quotations combinators locals words ; +IN: compiler.graphviz + +: quotes ( str -- str' ) "\"" "\"" surround ; + +: graph, ( quot title -- ) + [ + quotes "digraph " " {" surround , + call + "}" , + ] { } make , ; inline + +: render-graph ( quot -- ) + { } make + "cfg" ".dot" make-unique-file + dup "Wrote " prepend print + [ [ concat ] dip ascii set-file-lines ] + [ { "dot" "-Tpng" "-O" } swap suffix try-process ] + [ ".png" append "open" swap 2array try-process ] + tri ; inline + +: attrs>string ( seq -- str ) + [ "" ] [ "," join "[" "]" surround ] if-empty ; + +: edge,* ( from to attrs -- ) + [ + [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri* + ";" % + ] "" make , ; + +: edge, ( from to -- ) + { } edge,* ; + +: bb-edge, ( from to -- ) + [ number>> number>string ] bi@ edge, ; + +: node-style, ( str attrs -- ) + [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ; + +: cfg-title ( cfg/mr -- string ) + [ + "=== word: " % + [ word>> name>> % ", label: " % ] + [ label>> name>> % ] + bi + ] "" make ; + +: cfg-vertex, ( bb -- ) + [ number>> number>string ] + [ kill-block? { "color=grey" "style=filled" } { } ? ] + bi node-style, ; + +: cfgs ( cfgs -- ) + [ + [ + [ [ cfg-vertex, ] each-basic-block ] + [ + [ + dup successors>> [ + bb-edge, + ] with each + ] each-basic-block + ] bi + ] over cfg-title graph, + ] each ; + +: optimized-cfg ( quot -- cfgs ) + { + { [ dup cfg? ] [ 1array ] } + { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] } + { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] } + [ ] + } cond ; + +: render-cfg ( cfg -- ) + optimized-cfg [ cfgs ] render-graph ; + +: dom-trees ( cfgs -- ) + [ + [ + needs-dominance drop + dom-childrens get [ + [ + bb-edge, + ] with each + ] assoc-each + ] over cfg-title graph, + ] each ; + +: render-dom ( cfg -- ) + optimized-cfg [ dom-trees ] render-graph ; + +SYMBOL: word-counts +SYMBOL: vertex-names + +: vertex-name ( call-graph-node -- string ) + label>> vertex-names get [ + word>> name>> + dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue + ] cache ; + +: vertex-attrs ( obj -- string ) + tail?>> { "style=bold,label=\"tail\"" } { } ? ; + +: call-graph-edge, ( from to attrs -- ) + [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ; + +: (call-graph-back-edges) ( string calls -- ) + [ { "color=red" } call-graph-edge, ] with each ; + +: (call-graph-edges) ( string children -- ) + [ + { + [ { } call-graph-edge, ] + [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ] + [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ] + [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ] + } cleave + ] with each ; + +: call-graph-edges ( call-graph-node -- ) + H{ } clone word-counts set + H{ } clone vertex-names set + [ "ROOT" ] dip (call-graph-edges) ; + +: render-call-graph ( tree -- ) + dup quotation? [ build-tree ] when + analyze-recursive drop + [ [ call-graph get call-graph-edges ] "Call graph" graph, ] + render-graph ; \ No newline at end of file diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor index f4ac97354d..90e88f64fb 100644 --- a/extra/coroutines/coroutines-tests.factor +++ b/extra/coroutines/coroutines-tests.factor @@ -7,7 +7,7 @@ USING: coroutines kernel sequences prettyprint tools.test math ; [ drop 1 coyield* 2 coyield* 3 coterminate ] cocreate ; : test2 ( -- co ) - [ 1+ coyield* ] cocreate ; + [ 1 + coyield* ] cocreate ; test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop [ test2 42 over coresume . dup *coresume . drop ] must-fail @@ -18,4 +18,4 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop { "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test -{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test \ No newline at end of file +{ 4+2/3 } [ [ 1 + coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 9d5c65aa94..10f99058b5 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -6,5 +6,5 @@ IN: crypto.barrett : barrett-mu ( n size -- mu ) #! Calculates Barrett's reduction parameter mu #! size = word size in bits (8, 16, 32, 64, ...) - [ [ log2 1+ ] [ / 2 * ] bi* ] + [ [ log2 1 + ] [ / 2 * ] bi* ] [ 2^ rot ^ swap /i ] 2bi ; diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index 286a313fda..30650c1e40 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -11,7 +11,7 @@ IN: crypto.passwd-md5 "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline : to64 ( v n -- string ) - [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ] + [ [ -6 shift ] [ 6 2^ 1 - bitand lookup-table ] bi ] replicate nip ; inline PRIVATE> diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index f4ef4687b5..917e98a6ee 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -26,7 +26,7 @@ CONSTANT: public-key 65537 : modulus-phi ( numbits -- n phi ) #! Loop until phi is not divisible by the public key. dup rsa-primes [ * ] 2keep - [ 1- ] bi@ * + [ 1 - ] bi@ * dup public-key gcd nip 1 = [ rot drop ] [ diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 40c0b791cf..615b38daf6 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -29,7 +29,7 @@ IN: ctags.etags H{ } clone swap [ swap [ etag-add ] keep ] each ; : lines>bytes ( seq n -- bytes ) - head 0 [ length 1+ + ] reduce ; + head 0 [ length 1 + + ] reduce ; : file>lines ( path -- lines ) ascii file-lines ; @@ -40,7 +40,7 @@ IN: ctags.etags 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 1- lines>bytes number>string % + 1 - lines>bytes number>string % ] "" make ; : etag-length ( vector -- n ) @@ -72,4 +72,4 @@ IN: ctags.etags [ etag-strings ] dip ascii set-file-lines ; : etags ( path -- ) - [ (ctags) sort-values etag-hash >alist ] dip etags-write ; \ No newline at end of file + [ (ctags) sort-values etag-hash >alist ] dip etags-write ; diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index dc08656f7e..77defb081d 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -68,7 +68,7 @@ M: from-sequence cursor-get-unsafe >from-sequence< nth-unsafe ; M: from-sequence cursor-advance - [ 1+ ] change-n drop ; + [ 1 + ] change-n drop ; : >input ( seq -- cursor ) 0 from-sequence boa ; inline diff --git a/extra/db/info/info.factor b/extra/db/info/info.factor new file mode 100644 index 0000000000..66409f2834 --- /dev/null +++ b/extra/db/info/info.factor @@ -0,0 +1,15 @@ +USING: accessors sequences generalizations io.encodings.utf8 db.postgresql parser combinators vocabs.parser db.sqlite +io.files ; +IN: db.info +! having sensative (and likely to change) information directly in source code seems a bad idea +: get-info ( -- lines ) current-vocab name>> "vocab:" "/dbinfo.txt" surround utf8 file-lines ; +SYNTAX: get-psql-info get-info 5 firstn + { + [ >>host ] + [ >>port ] + [ >>username ] + [ [ f ] [ ] if-empty >>password ] + [ >>database ] + } spread parsed ; + +SYNTAX: get-sqlite-info get-info first parsed ; \ No newline at end of file diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 755c57ceda..6630d2addb 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,16 +1,34 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ; +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see +math.ratios ; IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; [ 3 ] [ 9 3 divide ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide + } +] [ + [ 3 0 divide ] [ ] recover +] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] +[ \ divide [ see ] with-string-writer ] unit-test DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; [ 3 ] [ 9 3 divide* ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide* + } +] [ [ 3 0 divide* ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor index af080f61eb..72f553c0f7 100644 --- a/extra/dns/misc/misc.factor +++ b/extra/dns/misc/misc.factor @@ -16,7 +16,7 @@ IN: dns.misc ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; +: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 644533d3a2..773fe31ea6 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -120,7 +120,7 @@ DEFER: query->rrs ! have-delegates? ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; +: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ; : is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ; diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index f47eb7010c..6934d3bbd9 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -10,7 +10,7 @@ MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ; +: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor index eaa0d3bb69..c1e93078f7 100644 --- a/extra/drills/deployed/deploy.factor +++ b/extra/drills/deployed/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-unicode? f } - { deploy-threads? t } - { deploy-math? t } { deploy-name "drills" } - { deploy-ui? t } + { deploy-c-types? t } { "stop-after-last-window?" t } - { deploy-word-props? f } - { deploy-c-types? f } - { deploy-io 2 } - { deploy-word-defs? f } - { deploy-reflection 1 } + { deploy-unicode? t } + { deploy-threads? t } + { deploy-reflection 6 } + { deploy-word-defs? t } + { deploy-math? t } + { deploy-ui? t } + { deploy-word-props? t } + { deploy-io 3 } } diff --git a/extra/drills/deployed/deployed.factor b/extra/drills/deployed/deployed.factor index 43873c99bb..5681c73438 100644 --- a/extra/drills/deployed/deployed.factor +++ b/extra/drills/deployed/deployed.factor @@ -1,11 +1,11 @@ -USING: accessors arrays cocoa.dialogs combinators continuations +USING: arrays cocoa.dialogs combinators continuations fry grouping io.encodings.utf8 io.files io.styles kernel math math.parser models models.arrow models.history namespaces random sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts wrap.strings system ; - +EXCLUDE: accessors => change-model ; IN: drills.deployed SYMBOLS: it startLength ; : big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; diff --git a/extra/drills/drills.factor b/extra/drills/drills.factor index 9ee4e9b6eb..1da1fcaa1d 100644 --- a/extra/drills/drills.factor +++ b/extra/drills/drills.factor @@ -1,16 +1,17 @@ -USING: accessors arrays cocoa.dialogs combinators continuations +USING: arrays cocoa.dialogs combinators continuations fry grouping io.encodings.utf8 io.files io.styles kernel math math.parser models models.arrow models.history namespaces random sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts wrap.strings ; +EXCLUDE: accessors => change-model ; IN: drills SYMBOLS: it startLength ; : big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; : card ( model quot -- button ) big [ next ] ; -: op ( quot str -- gadget )
+{ $values { "model" "values the table is to display" } { "table" table } } +{ $description "Creates an " { $link table } } ; + +HELP: +{ $values { "table" table } } +{ $description "Creates an " { $link table } " with no initial values to display" } ; + +HELP: +{ $values { "column-model" "values the table is to display" } { "table" table } } +{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ; + +HELP: +{ $values { "table" table } } +{ $description "Creates an model-list with no initial values to display" } ; + +HELP: indexed +{ $values { "table" table } } +{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ; + +HELP: +{ $values { "model" model } { "gadget" model-field } } +{ $description "Creates a field with an initial value" } ; + +HELP: +{ $values { "field" model-field } } +{ $description "Creates a field with an empty initial value" } ; + +HELP: +{ $values { "model" model } { "field" model-field } } +{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ; + +HELP: +{ $values { "model" model } { "gadget" model-field } } +{ $description "Creates an editor with an initial value" } ; + +HELP: +{ $values { "editor" "an editor" } } +{ $description "Creates a editor with an empty initial value" } ; + +HELP: +{ $values { "model" model } { "editor" "an editor" } } +{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ; + +HELP: +{ $values { "field" action-field } } +{ $description "Field that updates its model with its contents when the user hits the return key" } ; + +HELP: IMG-MODEL-BTN: +{ $syntax "IMAGE-MODEL-BTN: filename" } +{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ; + +HELP: IMG-BTN: +{ $syntax "[ do-something ] IMAGE-BTN: filename" } +{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ; + +HELP: output-model +{ $values { "gadget" gadget } { "model" model } } +{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ; \ No newline at end of file diff --git a/extra/ui/gadgets/controls/controls.factor b/extra/ui/gadgets/controls/controls.factor new file mode 100644 index 0000000000..649c9052fd --- /dev/null +++ b/extra/ui/gadgets/controls/controls.factor @@ -0,0 +1,83 @@ +USING: accessors assocs arrays kernel models monads sequences +models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons +ui.gadgets.buttons.private ui.gadgets.editors words images.loader +ui.gadgets.scrollers ui.images vocabs.parser lexer +models.range ui.gadgets.sliders ; +QUALIFIED-WITH: ui.gadgets.sliders slider +QUALIFIED-WITH: ui.gadgets.tables tbl +EXCLUDE: ui.gadgets.editors => model-field ; +IN: ui.gadgets.controls + +TUPLE: model-btn < button hook value ; +: ( gadget -- button ) [ + [ dup hook>> [ call( button -- ) ] [ drop ] if* ] + [ [ [ value>> ] [ ] bi or ] keep set-control-value ] + [ model>> f swap (>>value) ] tri + ] model-btn new-button f >>model ; +: ( text -- button ) border-button-theme ; + +TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ; +M: table tbl:column-titles column-titles>> ; +M: table tbl:column-alignment column-alignment>> ; +M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ; +M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ; +M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; + +: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer + f >>actions dup actions>> [ set-model ] curry >>action ; +:
( model -- table ) table new-table ; +: ( -- table ) V{ } clone
; +: ( column-model -- table )
[ 1array ] >>quot ; +: ( -- table ) V{ } clone ; +: indexed ( table -- table ) f >>val-quot ; + +TUPLE: model-field < field model* ; +: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ; +: ( model -- gadget ) model-field new-field swap init-field >>model* ; +M: model-field graft* + [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ] + [ dup editor>> model>> add-connection ] + [ dup model*>> add-connection ] tri ; +M: model-field ungraft* + [ dup editor>> model>> remove-connection ] + [ dup model*>> remove-connection ] bi ; +M: model-field model-changed 2dup model*>> = + [ [ value>> ] [ editor>> ] bi* set-editor-string ] + [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ; + +: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor + field-theme { 1 0 } >>align ; inline +: ( -- field ) "" ; +: ( model -- field ) "" switch-models ; +: ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ; +: ( -- editor ) "" ; +: ( model -- editor ) "" switch-models ; + +: ( -- field ) f dup [ set-control-value ] curry >>quot + f >>model ; + +: ( init page min max step -- slider ) horizontal slider: ; + +: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround dup cached-image drop ; +SYNTAX: IMG-MODEL-BTN: image-prep [ ] curry over push-all ; + +SYNTAX: IMG-BTN: image-prep [ swap