-USING: sequences sequences.private arrays bit-arrays kernel
+USING: alien sequences sequences.private arrays bit-arrays kernel
tools.test math random ;
IN: bit-arrays.tests
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
+[ 1 ] [ ?{ f t f t } byte-length ] unit-test
+
+[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
+
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.data accessors math alien.accessors kernel
-kernel.private sequences sequences.private byte-arrays
-parser prettyprint.custom fry ;
+USING: alien alien.data accessors io.binary math math.bitwise
+alien.accessors kernel kernel.private sequences
+sequences.private byte-arrays parser prettyprint.custom fry
+locals ;
IN: bit-arrays
TUPLE: bit-array
: n>byte ( m -- n ) -3 shift ; inline
-: byte/bit ( n alien -- byte bit )
- over n>byte alien-unsigned-1 swap 7 bitand ; inline
+: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
-: set-bit ( ? byte bit -- byte )
- 2^ rot [ bitor ] [ bitnot bitand ] if ; inline
+: bit-index ( n bit-array -- bit# byte# byte-array )
+ [ >fixnum bit/byte ] [ underlying>> ] bi* ; inline
: bits>cells ( m -- n ) 31 + -5 shift ; inline
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
- '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
+ '[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
M: bit-array length length>> ; inline
M: bit-array nth-unsafe
- [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
+ bit-index nth-unsafe swap bit? ; inline
+
+:: toggle-bit ( ? n x -- y )
+ x n ? [ set-bit ] [ clear-bit ] if ; inline
M: bit-array set-nth-unsafe
- [ >fixnum ] [ underlying>> ] bi*
- [ byte/bit set-bit ] 2keep
- swap n>byte set-alien-unsigned-1 ; inline
+ bit-index [ toggle-bit ] change-nth-unsafe ; inline
GENERIC: clear-bits ( bit-array -- )
bit-array boa
dup clean-up ; inline
-M: bit-array byte-length length 7 + -3 shift ; inline
+M: bit-array byte-length length bits>bytes ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array )
- dup 0 = [
- <bit-array>
- ] [
- [ log2 1 + <bit-array> 0 ] keep
- [ dup 0 = ] [
- [ pick underlying>> pick set-alien-unsigned-1 ] keep
- [ 1 + ] [ -8 shift ] bi*
- ] until 2drop
- ] if ;
+ dup 0 =
+ [ <bit-array> ]
+ [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
: bit-array>integer ( bit-array -- n )
- 0 swap underlying>> dup length iota <reversed> [
- alien-unsigned-1 swap 8 shift bitor
- ] with each ;
+ underlying>> le> ;
INSTANCE: bit-array sequence
: save/restore-error ( quot -- )
error get-global
+ original-error get-global
error-continuation get-global
- [ call ] 2dip
+ [ call ] 3dip
error-continuation set-global
+ original-error set-global
error set-global ; inline
run-bootstrap-init
f error set-global
+ f original-error set-global
f error-continuation set-global
nano-count swap - bootstrap-time set-global
--- /dev/null
+USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test ;
+IN: compiler.cfg.alias-analysis.tests
+
+! Redundant load elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Store-load forwarding
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Dead store elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Not a redundant load
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 0 1 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##set-slot-imm f 0 1 1 0 }
+ T{ ##slot-imm f 2 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Not a redundant store
+[
+ V{
+ 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{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 3 1 1 0 }
+ }
+] [
+ V{
+ 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{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 3 1 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! There's a redundant load, but not a redundant store
+[
+ V{
+ 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{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ T{ ##slot f 5 0 3 0 0 }
+ T{ ##set-slot-imm f 3 0 1 0 }
+ T{ ##copy f 6 3 any-rep }
+ }
+] [
+ V{
+ 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{ ##slot-imm f 4 0 1 0 }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ T{ ##slot f 5 0 3 0 0 }
+ T{ ##set-slot-imm f 3 0 1 0 }
+ T{ ##slot-imm f 6 0 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Fresh allocations don't alias existing values
+
+! Redundant load elimination
+[
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##copy f 5 3 any-rep }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ T{ ##set-slot-imm f 2 1 1 0 }
+ T{ ##slot-imm f 5 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##slot-imm f 5 1 1 0 }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 1 4 1 0 }
+ T{ ##slot-imm f 5 1 1 0 }
+ T{ ##set-slot-imm f 3 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Storing a new alias class into another object means that heap-ac
+! can now alias the new ac
+[
+ V{
+ 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{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 0 4 1 0 }
+ T{ ##set-slot-imm f 4 2 1 0 }
+ T{ ##slot-imm f 5 3 1 0 }
+ T{ ##set-slot-imm f 1 5 1 0 }
+ T{ ##slot-imm f 6 4 1 0 }
+ }
+] [
+ V{
+ 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{ ##allot f 4 16 array }
+ T{ ##set-slot-imm f 0 4 1 0 }
+ T{ ##set-slot-imm f 4 2 1 0 }
+ T{ ##slot-imm f 5 3 1 0 }
+ T{ ##set-slot-imm f 1 5 1 0 }
+ T{ ##slot-imm f 6 4 1 0 }
+ } alias-analysis-step
+] unit-test
+
+! Compares between objects which cannot alias are eliminated
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##allot f 1 16 array }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##allot f 1 16 array }
+ T{ ##compare f 2 0 1 cc= }
+ } alias-analysis-step
+] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors words vectors combinators combinators.short-circuit
-sets classes layouts cpu.architecture
+sets classes layouts fry cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
-compiler.cfg.copy-prop
compiler.cfg.registers
+compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
! e = c
! x[1] = c
+! Local copy propagation
+SYMBOL: copies
+
+: resolve ( vreg -- vreg ) copies get ?at drop ;
+
+: record-copy ( ##copy -- )
+ [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
! Map vregs -> alias classes
SYMBOL: vregs>acs
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-GENERIC: aliases ( vreg -- vregs )
-
-M: integer aliases
+: aliases ( vreg -- vregs )
#! All vregs which may contain the same value as vreg.
vreg>ac ac>vregs ;
-M: word aliases
- 1array ;
-
: each-alias ( vreg quot -- )
[ aliases ] dip each ; inline
+: merge-acs ( vreg into -- )
+ [ vreg>ac ] dip
+ 2dup eq? [ 2drop ] [
+ [ ac>vregs ] dip
+ [ vregs>acs get '[ [ _ ] dip _ set-at ] each ]
+ [ acs>vregs get at push-all ]
+ 2bi
+ ] if ;
+
! Map vregs -> slot# -> vreg
SYMBOL: live-slots
: remember-set-slot ( slot#/f vreg -- )
over [
[ record-constant-set-slot ]
- [ kill-constant-set-slot ] 2bi
+ [ kill-constant-set-slot ]
+ 2bi
] [ nip kill-computed-set-slot ] if ;
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
- #! Return a ##load-immediate value, or f if the vreg was not
- #! assigned by an ##load-immediate.
- resolve constants get at ;
-
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
-M: ##slot insn-slot# slot>> constant ;
+M: ##slot insn-slot# drop f ;
M: ##slot-imm insn-slot# slot>> ;
-M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot insn-slot# drop f ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field insn-slot# offset>> ;
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
- H{ } clone constants set
H{ } clone copies set
0 ac-counter set
! a new value, except boxing instructions haven't been
! inserted yet.
dup defs-vreg [
- over defs-vreg-rep int-rep eq?
+ over defs-vreg-rep { int-rep tagged-rep } member?
[ set-heap-ac ] [ set-new-ac ] if
] when* ;
M: ##phi analyze-aliases*
dup defs-vreg set-heap-ac ;
-M: ##load-immediate analyze-aliases*
- call-next-method
- dup [ val>> ] [ dst>> ] bi constants get set-at ;
-
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
M: ##read analyze-aliases*
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
- 2dup live-slot dup [
- 2nip any-rep \ ##copy new-insn analyze-aliases* nip
- ] [
- drop remember-slot
- ] if ;
+ 2dup live-slot dup
+ [ 2nip <copy> analyze-aliases* nip ]
+ [ drop remember-slot ]
+ if ;
: idempotent? ( value slot#/f vreg -- ? )
#! Are we storing a value back to the same slot it was read
M: ##write analyze-aliases*
dup
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
- [ remember-set-slot drop ] [ load-slot ] 3bi ;
+ 3dup idempotent? [ 3drop ] [
+ [ 2drop heap-ac get merge-acs ]
+ [ remember-set-slot drop ]
+ [ load-slot ]
+ 3tri
+ ] if ;
M: ##copy analyze-aliases*
#! The output vreg gets the same alias class as the input
M: ##compare analyze-aliases*
call-next-method
dup useless-compare? [
- dst>> f \ ##load-constant new-insn
+ dst>> f \ ##load-reference new-insn
analyze-aliases*
] when ;
compute-live-stores
eliminate-dead-stores ;
-: alias-analysis ( cfg -- cfg' )
- [ alias-analysis-step ] local-optimization ;
+: alias-analysis ( cfg -- cfg )
+ dup [ alias-analysis-step ] simple-optimization ;
! Copyright (C) 2008, 2010 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 layouts
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stack-frame ;
+combinators classes words cpu.architecture layouts compiler.cfg
+compiler.cfg.rpo compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
M: ##call compute-stack-frame* drop frame-required? on ;
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+ drop
frame-required? on
- stack-frame new
- swap tagged-values>> length cells >>gc-root-size
- t >>calls-vm?
- request-stack-frame ;
-
-M: _spill-area-size compute-stack-frame*
- n>> stack-frame get (>>spill-area-size) ;
+ stack-frame new t >>calls-vm? request-stack-frame ;
M: insn compute-stack-frame*
- class frame-required? word-prop [
- frame-required? on
- ] when ;
+ class "frame-required?" word-prop
+ [ frame-required? on ] when ;
-\ _spill t frame-required? set-word-prop
-\ ##unary-float-function t frame-required? set-word-prop
-\ ##binary-float-function t frame-required? set-word-prop
+: initial-stack-frame ( -- stack-frame )
+ stack-frame new cfg get spill-area-size>> >>spill-area-size ;
: compute-stack-frame ( insns -- )
frame-required? off
- stack-frame new stack-frame set
- [ compute-stack-frame* ] each
+ initial-stack-frame stack-frame set
+ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block
stack-frame get dup stack-frame-size >>total-size drop ;
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
- [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
+: build-stack-frame ( cfg -- cfg )
[
+ [ compute-stack-frame ]
[
- [ compute-stack-frame ]
- [ insert-pro/epilogues ]
- bi
- ] change-instructions
+ frame-required? get stack-frame get f ?
+ >>stack-frame
+ ] bi
] with-scope ;
USING: tools.test kernel sequences words sequences.private fry
-prettyprint alien alien.accessors math.private compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-compiler.cfg arrays locals byte-arrays kernel.private math
-slots.private vectors sbufs strings math.partial-dispatch
-hashtables assocs combinators.short-circuit
-strings.private accessors compiler.cfg.instructions ;
+prettyprint alien alien.accessors math.private
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger
+compiler.cfg.optimizer compiler.cfg.rpo
+compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
+arrays locals byte-arrays kernel.private math slots.private
+vectors sbufs strings math.partial-dispatch hashtables assocs
+combinators.short-circuit strings.private accessors
+compiler.cfg.instructions compiler.cfg.representations ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- )
- '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+: unit-test-builder ( quot -- )
+ '[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
set-string-nth-fast
]
} [
- unit-test-cfg
+ unit-test-builder
] each
: test-1 ( -- ) test-1 ;
test-1
test-2
test-3
-} [ unit-test-cfg ] each
+} [ unit-test-builder ] each
{
byte-array
alien-float
alien-double
} [| word |
- { class } word '[ _ declare 10 _ execute ] unit-test-cfg
- { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+ { class } word '[ _ declare 10 _ execute ] unit-test-builder
+ { class fixnum } word '[ _ declare _ execute ] unit-test-builder
] each
{
set-alien-unsigned-2
set-alien-unsigned-4
} [| word |
- { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
- { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+ { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
+ { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
] each
- { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
- { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+ { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
+ { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
- { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
- { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+ { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
+ { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
- { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
- { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+ { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
+ { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
] each
: count-insns ( quot insn-check -- ? )
- [ test-mr [ instructions>> ] map ] dip
- '[ _ count ] map-sum ; inline
+ [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
+ count ; inline
: contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline
[ t ] [
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ t ] [
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
- [ ##set-alien-integer-1? ] contains-insn?
+ [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
+] unit-test
+
+[ t t ] [
+ [ { byte-array fixnum } declare alien-cell ]
+ [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
+ [ [ ##box-alien? ] contains-insn? ]
+ bi
+] unit-test
+
+[ f ] [
+ [ { byte-array integer } declare alien-cell ]
+ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
[ [ ##allot? ] contains-insn? ] bi
] unit-test
- [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
+ [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
] when
! Regression. Make sure everything is inlined correctly
and ;
: emit-trivial-if ( -- )
- ds-pop f cc/= ^^compare-imm ds-push ;
+ [ f cc/= ^^compare-imm ] unary-op ;
: trivial-not-if? ( #if -- ? )
children>> first2
and ;
: emit-trivial-not-if ( -- )
- ds-pop f cc= ^^compare-imm ds-push ;
+ [ f cc= ^^compare-imm ] unary-op ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
number
{ instructions vector }
{ successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
: <basic-block> ( -- bb )
basic-block new
M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
-spill-area-size reps
+spill-area-size
+stack-frame
post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ;
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
-
-TUPLE: mr { instructions array } word label ;
-
-: <mr> ( instructions word label -- mr )
- mr new
- swap >>label
- swap >>word
- swap >>instructions ;
USING: kernel combinators.short-circuit accessors math sequences
sets assocs compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization
-compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
+compiler.cfg.utilities compiler.cfg.finalization
+compiler.utilities ;
IN: compiler.cfg.checker
! Check invariants
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##compare-branch? ]
- [ ##compare-imm-branch? ]
- [ ##compare-float-ordered-branch? ]
- [ ##compare-float-unordered-branch? ]
- [ ##fixnum-add? ]
- [ ##fixnum-sub? ]
- [ ##fixnum-mul? ]
+ [ conditional-branch-insn? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
[ check-successors ]
bi ;
-ERROR: bad-live-in ;
-
-ERROR: undefined-values uses defs ;
-
-: check-mr ( mr -- )
- ! Check that every used register has a definition
- instructions>>
- [ [ uses-vregs ] map concat ]
- [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
- 2dup subset? [ 2drop ] [ undefined-values ] if ;
-
: check-cfg ( cfg -- )
- [ [ check-basic-block ] each-basic-block ]
- [ build-mr check-mr ]
- bi ;
+ [ check-basic-block ] each-basic-block ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
SYMBOLS:
vcc-all vcc-notall vcc-any vcc-none ;
+SYMBOLS: cc-o cc/o ;
+
: negate-cc ( cc -- cc' )
H{
{ cc< cc/< }
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/<>= cc<>= }
+ { cc-o cc/o }
+ { cc/o cc-o }
} at ;
: negate-vcc ( cc -- cc' )
--- /dev/null
+USING: compiler.cfg.copy-prop tools.test namespaces kernel
+compiler.cfg.debugger compiler.cfg accessors
+compiler.cfg.registers compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.copy-prop.tests
+
+: test-copy-propagation ( -- )
+ cfg new 0 get >>entry copy-propagation drop ;
+
+! Simple example
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##peek f 1 D 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##copy f 2 0 any-rep }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
+ T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
+ T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 5 D 1 }
+ T{ ##replace f 6 D 2 }
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 6 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+ V{
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 4 D 1 }
+ T{ ##replace f 4 D 2 }
+ T{ ##branch }
+ }
+] [ 5 get instructions>> ] unit-test
+
+! Test optimistic assumption
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f 2 D 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 2 edge
+2 { 2 3 } edges
+3 4 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+ V{
+ T{ ##replace f 0 D 1 }
+ T{ ##branch }
+ }
+] [ 3 get instructions>> ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! 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.predecessors ;
+USING: sets kernel namespaces assocs accessors sequences grouping
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions
+compiler.cfg.predecessors ;
+FROM: namespaces => set ;
IN: compiler.cfg.copy-prop
-! The first three definitions are also used in compiler.cfg.alias-analysis.
+<PRIVATE
+
+SYMBOL: changed?
+
SYMBOL: copies
-! Initialized per-basic-block; a mapping from inputs to dst for eliminating
-! redundant phi instructions
+! Initialized per-basic-block; a mapping from inputs to dst for
+! eliminating redundant ##phi instructions
SYMBOL: phis
: resolve ( vreg -- vreg )
- copies get ?at drop ;
-
-: (record-copy) ( dst src -- )
- swap copies get set-at ; inline
+ copies get at ;
-: record-copy ( ##copy -- )
- [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
-
-<PRIVATE
+: record-copy ( dst src -- )
+ swap copies get maybe-set-at [ changed? on ] when ; inline
GENERIC: visit-insn ( insn -- )
-M: ##copy visit-insn record-copy ;
+M: ##copy visit-insn
+ [ dst>> ] [ src>> resolve ] bi
+ dup [ record-copy ] [ 2drop ] if ;
-: useless-phi ( dst inputs -- ) first (record-copy) ;
+: useless-phi ( dst inputs -- ) first record-copy ;
-: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+: redundant-phi ( dst inputs -- ) phis get at record-copy ;
-: record-phi ( dst inputs -- ) phis get set-at ;
+: record-phi ( dst inputs -- )
+ [ phis get set-at ] [ drop dup record-copy ] 2bi ;
M: ##phi visit-insn
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
- {
- { [ dup all-equal? ] [ useless-phi ] }
- { [ dup phis get key? ] [ redundant-phi ] }
- [ record-phi ]
- } cond ;
+ dup phis get key? [ redundant-phi ] [
+ dup sift
+ dup all-equal?
+ [ nip useless-phi ]
+ [ drop record-phi ] if
+ ] if ;
+
+M: vreg-insn visit-insn
+ defs-vreg [ dup record-copy ] when* ;
M: insn visit-insn drop ;
-: collect-copies ( cfg -- )
- H{ } clone copies set
+: (collect-copies) ( cfg -- )
[
- H{ } clone phis set
+ phis get clear-assoc
instructions>> [ visit-insn ] each
] each-basic-block ;
+: collect-copies ( cfg -- )
+ H{ } clone copies set
+ H{ } clone phis set
+ '[
+ changed? off
+ _ (collect-copies)
+ changed? get
+ ] loop ;
+
GENERIC: update-insn ( insn -- keep? )
M: ##copy update-insn drop f ;
M: ##phi update-insn
- dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+ dup call-next-method drop
+ [ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
+
+M: vreg-insn update-insn rename-insn-uses t ;
-M: insn update-insn rename-insn-uses t ;
+M: insn update-insn drop t ;
: rename-copies ( cfg -- )
- copies get dup assoc-empty? [ 2drop ] [
- renamings set
- [
- instructions>> [ update-insn ] filter! drop
- ] each-basic-block
- ] if ;
+ copies get renamings set
+ [ [ update-insn ] filter! ] simple-optimization ;
PRIVATE>
: copy-propagation ( cfg -- cfg' )
needs-predecessors
- [ collect-copies ]
- [ rename-copies ]
- [ ]
- tri ;
+ dup collect-copies
+ dup rename-copies ;
entry>> instructions>> ;
[ V{
- T{ ##load-immediate { dst 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { 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 1 } { val 8 } }
- T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##load-integer { dst 1 } { val 8 } }
+ T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { 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 3 } { val 8 } }
+ T{ ##load-integer { 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 3 } { val 8 } }
+ T{ ##load-integer { 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{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
- T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
arrays hashtables classes.tuple accessors prettyprint
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.registers
compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.mr compiler.cfg.representations.preferred
-compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.finalization
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.representations compiler.cfg.gc-checks
+compiler.cfg.save-contexts compiler.cfg
+compiler.cfg.representations.preferred ;
+FROM: compiler.cfg.linearization => number-blocks ;
IN: compiler.cfg.debugger
-GENERIC: test-cfg ( quot -- cfgs )
+GENERIC: test-builder ( quot -- cfgs )
-M: callable test-cfg
+M: callable test-builder
0 vreg-counter set-global
build-tree optimize-tree gensym build-cfg ;
-M: word test-cfg
+M: word test-builder
0 vreg-counter set-global
[ build-tree optimize-tree ] keep build-cfg ;
-: test-mr ( quot -- mrs )
- test-cfg [
+: test-optimizer ( quot -- cfgs )
+ test-builder [ [ optimize-cfg ] with-cfg ] map ;
+
+: test-ssa ( quot -- cfgs )
+ test-builder [
[
optimize-cfg
- build-mr
] with-cfg
] map ;
-: insn. ( insn -- )
- tuple>array but-last [ pprint bl ] each nl ;
+: test-flat ( quot -- cfgs )
+ test-builder [
+ [
+ optimize-cfg
+ select-representations
+ insert-gc-checks
+ insert-save-contexts
+ ] with-cfg
+ ] map ;
-: mr. ( mrs -- )
+: test-regs ( quot -- cfgs )
+ test-builder [
+ [
+ optimize-cfg
+ finalize-cfg
+ ] with-cfg
+ ] map ;
+
+GENERIC: insn. ( insn -- )
+
+M: ##phi insn.
+ clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
+ call-next-method ;
+
+M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
+
+: block. ( bb -- )
+ "=== Basic block #" write dup block-number . nl
+ dup instructions>> [ insn. ] each nl
+ successors>> [
+ "Successors: " write
+ [ block-number unparse ] map ", " join print nl
+ ] unless-empty ;
+
+: cfg. ( cfg -- )
[
+ dup linearization-order number-blocks
"=== word: " write
dup word>> pprint
", label: " write
dup label>> pprint nl nl
- instructions>> [ insn. ] each
- nl
- ] each ;
+ dup linearization-order [ block. ] each
+ "=== stack frame: " write
+ stack-frame>> .
+ ] with-scope ;
+
+: cfgs. ( cfgs -- )
+ [ nl ] [ cfg. ] interleave ;
-: test-mr. ( quot -- )
- test-mr mr. ; inline
+: ssa. ( quot -- ) test-ssa cfgs. ;
+: flat. ( quot -- ) test-flat cfgs. ;
+: regs. ( quot -- ) test-regs cfgs. ;
! Prettyprinting
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations generic kernel locals
--- /dev/null
+! Copyright (C) 2009, 2010 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.registers fry kernel
+locals namespaces sequences sets sorting math.vectors
+make math combinators.short-circuit vectors ;
+FROM: namespaces => set ;
+IN: compiler.cfg.dependence
+
+! Dependence graph construction
+
+SYMBOL: roots
+SYMBOL: node-number
+SYMBOL: nodes
+
+SYMBOL: +data+
+SYMBOL: +control+
+
+! Nodes in the dependency graph
+! These need to be numbered so that the same instruction
+! will get distinct nodes if it occurs multiple times
+TUPLE: node
+ number insn precedes follows
+ children parent
+ registers parent-index ;
+
+M: node equal? [ number>> ] bi@ = ;
+
+M: node hashcode* nip number>> ;
+
+: <node> ( insn -- node )
+ node new
+ node-number counter >>number
+ swap >>insn
+ H{ } clone >>precedes
+ V{ } clone >>follows ;
+
+: ready? ( node -- ? ) precedes>> assoc-empty? ;
+
+:: precedes ( first second how -- )
+ how second first precedes>> set-at ;
+
+:: add-data-edges ( nodes -- )
+ ! This builds up def-use information on the fly, since
+ ! we only care about local def-use
+ H{ } clone :> definers
+ nodes [| node |
+ node insn>> defs-vreg [ node swap definers set-at ] when*
+ node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
+ ] each ;
+
+UNION: stack-insn ##peek ##replace ##replace-imm ;
+
+UNION: slot-insn
+ ##read ##write ;
+
+UNION: memory-insn
+ ##load-memory ##load-memory-imm
+ ##store-memory ##store-memory-imm ;
+
+UNION: alien-call-insn
+ ##save-context
+ ##alien-invoke ##alien-indirect ##alien-callback
+ ##unary-float-function ##binary-float-function ;
+
+: chain ( node var -- )
+ dup get [
+ pick +control+ precedes
+ ] when*
+ set ;
+
+GENERIC: add-control-edge ( node insn -- )
+
+M: stack-insn add-control-edge
+ loc>> chain ;
+
+M: memory-insn add-control-edge
+ drop memory-insn chain ;
+
+M: slot-insn add-control-edge
+ drop slot-insn chain ;
+
+M: alien-call-insn add-control-edge
+ drop alien-call-insn chain ;
+
+M: object add-control-edge 2drop ;
+
+: add-control-edges ( nodes -- )
+ [
+ [ dup insn>> add-control-edge ] each
+ ] with-scope ;
+
+: set-follows ( nodes -- )
+ [
+ dup precedes>> keys [
+ follows>> push
+ ] with each
+ ] each ;
+
+: set-roots ( nodes -- )
+ [ ready? ] V{ } filter-as roots set ;
+
+: build-dependence-graph ( instructions -- )
+ [ <node> ] map {
+ [ add-control-edges ]
+ [ add-data-edges ]
+ [ set-follows ]
+ [ set-roots ]
+ [ nodes set ]
+ } cleave ;
+
+! Sethi-Ulmann numbering
+:: calculate-registers ( node -- registers )
+ node children>> [ 0 ] [
+ [ [ calculate-registers ] map natural-sort ]
+ [ length iota ]
+ bi v+ supremum
+ ] if-empty
+ node insn>> temp-vregs length +
+ dup node (>>registers) ;
+
+! Constructing fan-in trees
+
+: attach-parent ( node parent -- )
+ [ >>parent drop ]
+ [ [ ?push ] change-children drop ] 2bi ;
+
+: keys-for ( assoc value -- keys )
+ '[ nip _ = ] assoc-filter keys ;
+
+: choose-parent ( node -- )
+ ! If a node has control dependences, it has to be a root
+ ! Otherwise, choose one of the data dependences for a parent
+ dup precedes>> +control+ keys-for empty? [
+ dup precedes>> +data+ keys-for [ drop ] [
+ first attach-parent
+ ] if-empty
+ ] [ drop ] if ;
+
+: make-trees ( -- trees )
+ nodes get
+ [ [ choose-parent ] each ]
+ [ [ parent>> not ] filter ] bi ;
+
+ERROR: node-missing-parent trees nodes ;
+ERROR: node-missing-children trees nodes ;
+
+: flatten-tree ( node -- nodes )
+ [ children>> [ flatten-tree ] map concat ] keep
+ suffix ;
+
+: verify-parents ( trees -- trees )
+ nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
+ [ nodes get node-missing-parent ] unless ;
+
+: verify-children ( trees -- trees )
+ dup [ flatten-tree ] map concat
+ nodes get
+ { [ [ length ] bi@ = ] [ set= ] } 2&&
+ [ nodes get node-missing-children ] unless ;
+
+: verify-trees ( trees -- trees )
+ verify-parents verify-children ;
+
+: build-fan-in-trees ( -- )
+ make-trees verify-trees [
+ -1/0. >>parent-index
+ calculate-registers drop
+ ] each ;
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences namespaces combinators
-combinators.short-circuit classes vectors compiler.cfg
-compiler.cfg.instructions compiler.cfg.rpo ;
-IN: compiler.cfg.empty-blocks
-
-<PRIVATE
-
-: update-predecessor ( bb -- )
- ! We have to replace occurrences of bb with bb's successor
- ! in bb's predecessor's list of successors.
- dup predecessors>> first [
- [
- 2dup eq? [ drop successors>> first ] [ nip ] if
- ] with map
- ] change-successors drop ;
-
-: update-successor ( bb -- )
- ! We have to replace occurrences of bb with bb's predecessor
- ! in bb's sucessor's list of predecessors.
- dup successors>> first [
- [
- 2dup eq? [ drop predecessors>> first ] [ nip ] if
- ] with map
- ] change-predecessors drop ;
-
-SYMBOL: changed?
-
-: delete-basic-block ( bb -- )
- [ update-predecessor ] [ update-successor ] bi
- changed? on ;
-
-: delete-basic-block? ( bb -- ? )
- {
- [ instructions>> length 1 = ]
- [ predecessors>> length 1 = ]
- [ 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
- changed? get [ cfg-changed ] when ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.gc-checks compiler.cfg.representations
+compiler.cfg.save-contexts compiler.cfg.ssa.destruction
+compiler.cfg.build-stack-frame compiler.cfg.linear-scan
+compiler.cfg.scheduling ;
+IN: compiler.cfg.finalization
+
+: finalize-cfg ( cfg -- cfg' )
+ select-representations
+ schedule-instructions
+ insert-gc-checks
+ insert-save-contexts
+ destruct-ssa
+ linear-scan
+ build-stack-frame ;
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
-namespaces accessors sequences ;
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
- cfg new 0 get >>entry
- insert-gc-checks
- drop ;
+ cfg new 0 get >>entry cfg set ;
V{
T{ ##inc-d f 3 }
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##load-tagged f 3 0 }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 3 R 3 }
+ }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+ instructions>>
+ {
+ [ length 1 = ]
+ [ first ##check-nursery-branch? ]
+ } 1&& ;
+
+[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##load-tagged f 5 0 }
+ T{ ##replace f 5 D 0 }
+ T{ ##replace f 5 R 3 }
+ T{ ##call-gc f { 0 1 2 } }
+ T{ ##branch }
+ }
+]
+[
+ { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 2 D 0 }
+ T{ ##inc-d f 3 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f 2 D 1 }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+ { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+ V{
+ T{ ##load-tagged f 31 0 }
+ T{ ##replace f 31 D 0 }
+ T{ ##replace f 31 D 1 }
+ T{ ##replace f 31 D 2 }
+ T{ ##call-gc f { 2 } }
+ T{ ##branch }
+ }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test
+
+! Do the right thing with ##phi instructions
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##load-reference f 1 "hi" }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-reference f 2 "bye" }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+ { 1 tagged-rep }
+ { 2 tagged-rep }
+ { 3 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
+[ 2 ] [ 3 get instructions>> length ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
-cpu.architecture layouts namespaces
+USING: accessors assocs combinators fry kernel layouts locals
+math make namespaces sequences cpu.architecture
+compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
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.
+<PRIVATE
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+! gc-check
+! / \
+! | gc-call
+! \ /
+! bb
+
+! Any ##phi instructions at the start of bb are transplanted
+! into the gc-check block.
+
+: <gc-check> ( phis size -- bb )
+ [ <basic-block> ] 2dip
+ [
+ [ % ]
+ [
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ ##check-nursery-branch
+ ] bi*
+ ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+ '[
+ int-rep next-vreg-rep
+ [ 0 ##load-tagged ]
+ [ '[ [ _ ] dip ##replace ] each ] bi
+ ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+ [ <basic-block> ] 2dip
+ [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
+
+:: insert-guard ( body check bb -- )
+ bb predecessors>> check (>>predecessors)
+ V{ bb body } check (>>successors)
+
+ V{ check } body (>>predecessors)
+ V{ bb } body (>>successors)
+
+ V{ check body } bb (>>predecessors)
+
+ check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+ [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
+: gc-live-in ( bb -- vregs )
+ [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
+ append ;
+
+: live-tagged ( bb -- vregs )
+ gc-live-in [ rep-of tagged-rep? ] filter ;
+
+: remove-phis ( bb -- phis )
+ [ [ ##phi? ] partition ] change-instructions drop ;
+
: insert-gc-check ( bb -- )
- dup dup '[
- int-rep next-vreg-rep
- int-rep next-vreg-rep
- _ allocation-size
- f
- f
- _ uninitialized-locs
- \ ##gc new-insn
- prefix
- ] change-instructions drop ;
+ {
+ [ uninitialized-locs ]
+ [ live-tagged ]
+ [ remove-phis ]
+ [ allocation-size ]
+ [ ]
+ } cleave
+ (insert-gc-check) ;
+
+PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- over compute-uninitialized-sets
+ [
+ needs-predecessors
+ dup compute-ssa-live-sets
+ dup compute-uninitialized-sets
+ ] dip
[ insert-gc-check ] each
+ cfg-changed
] unless-empty ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators.short-circuit
-kernel layouts math namespaces sequences combinators splitting
-parser effects words cpu.architecture compiler.cfg.registers
+USING: accessors alien arrays byte-arrays classes.algebra
+combinators.short-circuit kernel layouts math namespaces
+sequences combinators splitting parser effects words
+cpu.architecture compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
>>
-: immutable? ( obj -- ? )
- { [ float? ] [ word? ] [ not ] } 1|| ; inline
-
: ^^load-literal ( obj -- dst )
- [ next-vreg dup ] dip {
- { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
- { [ dup immutable? ] [ ##load-constant ] }
- [ ##load-reference ]
- } cond ;
+ dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
: ^^offset>slot ( slot -- vreg' )
- cell 4 = 2 1 ? ^^shr-imm ;
+ cell 4 = 2 3 ? ^^shl-imm ;
-: ^^tag-fixnum ( src -- dst )
- tag-bits get ^^shl-imm ;
+: ^^unbox-f ( src -- dst )
+ drop 0 ^^load-literal ;
-: ^^untag-fixnum ( src -- dst )
- tag-bits get ^^sar-imm ;
+: ^^unbox-byte-array ( src -- dst )
+ ^^tagged>integer byte-array-offset ^^add-imm ;
+
+: ^^unbox-c-ptr ( src class -- dst )
+ {
+ { [ dup \ f class<= ] [ drop ^^unbox-f ] }
+ { [ dup alien class<= ] [ drop ^^unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
+ [ drop ^^unbox-any-c-ptr ]
+ } cond ;
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.rpo ;
+IN: compiler.cfg.height
+
+! Combine multiple stack height changes into one at the
+! start of the basic block.
+
+SYMBOL: ds-height
+SYMBOL: rs-height
+
+GENERIC: compute-heights ( insn -- )
+
+M: ##inc-d compute-heights n>> ds-height [ + ] change ;
+M: ##inc-r compute-heights n>> rs-height [ + ] change ;
+M: insn compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn' )
+
+: normalize-inc-d/r ( insn stack -- insn' )
+ swap n>> '[ _ - ] change f ; inline
+
+M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
+M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+
+GENERIC: loc-stack ( loc -- stack )
+
+M: ds-loc loc-stack drop ds-height ;
+M: rs-loc loc-stack drop rs-height ;
+
+GENERIC: <loc> ( n stack -- loc )
+
+M: ds-loc <loc> drop <ds-loc> ;
+M: rs-loc <loc> drop <rs-loc> ;
+
+: normalize-peek/replace ( insn -- insn' )
+ [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+
+M: ##peek normalize-height* normalize-peek/replace ;
+M: ##replace normalize-height* normalize-peek/replace ;
+
+M: insn normalize-height* ;
+
+: height-step ( insns -- insns' )
+ 0 ds-height set
+ 0 rs-height set
+ [ [ compute-heights ] each ]
+ [ [ [ normalize-height* ] map sift ] with-scope ] bi
+ ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
+ rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+
+: normalize-height ( cfg -- cfg' )
+ dup [ height-step ] simple-optimization ;
--- /dev/null
+Stack height normalization coalesces height changes at start of basic block
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra classes.union
-compiler.units alien byte-arrays compiler.constants combinators
-compiler.cfg.registers compiler.cfg.instructions.syntax ;
+math math.order layouts classes.union compiler.units alien
+byte-arrays combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
<<
! value numbering
TUPLE: pure-insn < insn ;
-! Stack operations
-INSN: ##load-immediate
+! Constants
+INSN: ##load-integer
def: dst/int-rep
-constant: val ;
+literal: val ;
INSN: ##load-reference
-def: dst/int-rep
-constant: obj ;
+def: dst/tagged-rep
+literal: obj ;
-INSN: ##load-constant
-def: dst/int-rep
-constant: obj ;
+! These three are inserted by representation selection
+INSN: ##load-tagged
+def: dst/tagged-rep
+literal: val ;
INSN: ##load-double
def: dst/double-rep
-constant: val ;
+literal: val ;
+
+INSN: ##load-vector
+def: dst
+literal: val rep ;
+! Stack operations
INSN: ##peek
-def: dst/int-rep
+def: dst/tagged-rep
literal: loc ;
INSN: ##replace
-use: src/int-rep
+use: src/tagged-rep
literal: loc ;
+INSN: ##replace-imm
+literal: src loc ;
+
INSN: ##inc-d
literal: n ;
INSN: ##jump
literal: word ;
+INSN: ##prologue ;
+
+INSN: ##epilogue ;
+
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
! Slot access
INSN: ##slot
-def: dst/int-rep
-use: obj/int-rep slot/int-rep ;
+def: dst/tagged-rep
+use: obj/tagged-rep slot/int-rep
+literal: scale tag ;
INSN: ##slot-imm
-def: dst/int-rep
-use: obj/int-rep
+def: dst/tagged-rep
+use: obj/tagged-rep
literal: slot tag ;
INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep ;
+use: src/tagged-rep obj/tagged-rep slot/int-rep
+literal: scale tag ;
INSN: ##set-slot-imm
-use: src/int-rep obj/int-rep
+use: src/tagged-rep obj/tagged-rep
literal: slot tag ;
-! String element access
-INSN: ##string-nth
-def: dst/int-rep
-use: obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-INSN: ##set-string-nth-fast
-use: src/int-rep obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##copy
+! Register transfers
+INSN: ##copy
def: dst
use: src
literal: rep ;
+PURE-INSN: ##tagged>integer
+def: dst/int-rep
+use: src/tagged-rep ;
+
! Integer arithmetic
PURE-INSN: ##add
def: dst/int-rep
PURE-INSN: ##add-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##sub
def: dst/int-rep
PURE-INSN: ##sub-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##mul
def: dst/int-rep
PURE-INSN: ##mul-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##and
def: dst/int-rep
PURE-INSN: ##and-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##or
def: dst/int-rep
PURE-INSN: ##or-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##xor
def: dst/int-rep
PURE-INSN: ##xor-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##shl
def: dst/int-rep
PURE-INSN: ##shl-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##shr
def: dst/int-rep
PURE-INSN: ##shr-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##sar
def: dst/int-rep
PURE-INSN: ##sar-imm
def: dst/int-rep
use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
PURE-INSN: ##min
def: dst/int-rep
literal: rep cc ;
PURE-INSN: ##test-vector
-def: dst/int-rep
+def: dst/tagged-rep
use: src1
temp: temp/int-rep
literal: rep vcc ;
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
-def: dst/int-rep
+def: dst/tagged-rep
use: src/int-rep
temp: temp/int-rep ;
PURE-INSN: ##box-displaced-alien
-def: dst/int-rep
-use: displacement/int-rep base/int-rep
+def: dst/tagged-rep
+use: displacement/int-rep base/tagged-rep
temp: temp/int-rep
literal: base-class ;
PURE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
-use: src/int-rep ;
-
-: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
-: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
+use: src/tagged-rep ;
PURE-INSN: ##unbox-alien
def: dst/int-rep
-use: src/int-rep ;
-
-: ##unbox-c-ptr ( dst src class -- )
- {
- { [ dup \ f class<= ] [ drop ##unbox-f ] }
- { [ dup alien class<= ] [ drop ##unbox-alien ] }
- { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
- [ drop ##unbox-any-c-ptr ]
- } cond ;
-
-! Alien accessors
-INSN: ##alien-unsigned-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
+use: src/tagged-rep ;
-INSN: ##alien-unsigned-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-cell
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-float
-def: dst/float-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-double
-def: dst/double-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-vector
+! Raw memory accessors
+INSN: ##load-memory
def: dst
-use: src/int-rep
-literal: offset rep ;
-
-INSN: ##set-alien-integer-1
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-integer-2
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
+use: base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
-INSN: ##set-alien-integer-4
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-cell
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-float
-use: src/int-rep
-literal: offset
-use: value/float-rep ;
+INSN: ##load-memory-imm
+def: dst
+use: base/int-rep
+literal: offset rep c-type ;
-INSN: ##set-alien-double
-use: src/int-rep
-literal: offset
-use: value/double-rep ;
+INSN: ##store-memory
+use: src base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
-INSN: ##set-alien-vector
-use: src/int-rep
-literal: offset
-use: value
-literal: rep ;
+INSN: ##store-memory-imm
+use: src base/int-rep
+literal: offset rep c-type ;
! Memory allocation
INSN: ##allot
-def: dst/int-rep
+def: dst/tagged-rep
literal: size class
temp: temp/int-rep ;
INSN: ##write-barrier
-use: src/int-rep slot/int-rep
+use: src/tagged-rep slot/int-rep
+literal: scale tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##write-barrier-imm
-use: src/int-rep
-literal: slot
+use: src/tagged-rep
+literal: slot tag
temp: temp1/int-rep temp2/int-rep ;
INSN: ##alien-global
literal: symbol library ;
INSN: ##vm-field
-def: dst/int-rep
+def: dst/tagged-rep
literal: offset ;
INSN: ##set-vm-field
-use: src/int-rep
+use: src/tagged-rep
literal: offset ;
! FFI
INSN: ##alien-callback
literal: params stack-frame ;
-! Instructions used by CFG IR only.
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-
+! Control flow
INSN: ##phi
def: dst
literal: inputs ;
-! Conditionals
+INSN: ##branch ;
+
+! Tagged conditionals
INSN: ##compare-branch
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
literal: cc ;
INSN: ##compare-imm-branch
-use: src1/int-rep
-constant: src2
-literal: cc ;
+use: src1/tagged-rep
+literal: src2 cc ;
PURE-INSN: ##compare
-def: dst/int-rep
-use: src1/int-rep src2/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
literal: cc
temp: temp/int-rep ;
PURE-INSN: ##compare-imm
-def: dst/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Integer conditionals
+INSN: ##compare-integer-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-integer-imm-branch
use: src1/int-rep
-constant: src2
+literal: src2 cc ;
+
+PURE-INSN: ##compare-integer
+def: dst/tagged-rep
+use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
+PURE-INSN: ##compare-integer-imm
+def: dst/tagged-rep
+use: src1/int-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Float conditionals
INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
literal: cc ;
PURE-INSN: ##compare-float-ordered
-def: dst/int-rep
+def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
PURE-INSN: ##compare-float-unordered
-def: dst/int-rep
+def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
! Overflowing arithmetic
INSN: ##fixnum-add
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-sub
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-mul
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/int-rep
+literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
-! Instructions used by machine IR only.
-INSN: _prologue
-literal: stack-frame ;
-
-INSN: _epilogue
-literal: stack-frame ;
-
-INSN: _label
-literal: label ;
-
-INSN: _branch
-literal: label ;
-
-INSN: _loop-entry ;
-
-INSN: _dispatch
-use: src/int-rep
-temp: temp ;
-
-INSN: _dispatch-label
-literal: label ;
-
-INSN: _compare-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1/int-rep
-constant: src2
-literal: cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+! GC checks
+INSN: ##check-nursery-branch
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
-INSN: _fixnum-mul
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+INSN: ##call-gc
+literal: gc-roots ;
+! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
-! These instructions operate on machine registers and not
-! virtual registers
-INSN: _spill
+INSN: ##spill
use: src
literal: rep dst ;
-INSN: _reload
+INSN: ##reload
def: dst
literal: rep src ;
-INSN: _spill-area-size
-literal: n ;
-
UNION: ##allocation
##allot
##box-alien
##box-displaced-alien ;
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
-! Instructions that kill all live vregs but cannot trigger GC
-UNION: partial-sync-insn
+! Instructions that clobber registers
+UNION: clobber-insn
+##call-gc
##unary-float-function
##binary-float-function ;
UNION: def-is-use-insn
##box-alien
##box-displaced-alien
-##string-nth
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
-SYMBOLS: def use temp literal constant ;
+SYMBOLS: def use temp literal ;
SYMBOL: scalar-rep
{ "use:" [ drop use ] }
{ "temp:" [ drop temp ] }
{ "literal:" [ drop literal ] }
- { "constant:" [ drop constant ] }
[ dupd parse-insn-slot-spec , ]
} case
] reduce drop
] { } make ;
-: insn-def-slot ( class -- slot/f )
- "insn-slots" word-prop
+: find-def-slot ( slots -- slot/f )
[ type>> def eq? ] find nip ;
+: insn-def-slot ( class -- slot/f )
+ "insn-slots" word-prop find-def-slot ;
+
: insn-use-slots ( class -- slots )
- "insn-slots" word-prop
- [ type>> use eq? ] filter ;
+ "insn-slots" word-prop [ type>> use eq? ] filter ;
: insn-temp-slots ( class -- slots )
- "insn-slots" word-prop
- [ type>> temp eq? ] filter ;
+ "insn-slots" word-prop [ type>> temp eq? ] filter ;
! We cannot reference words in compiler.cfg.instructions directly
! since that would create circularity.
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators combinators.short-circuit cpu.architecture
: emit-<displaced-alien> ( node -- )
dup emit-<displaced-alien>? [
- [ 2inputs [ ^^untag-fixnum ] dip ] dip
- node-input-infos second class>>
- ^^box-displaced-alien ds-push
+ '[
+ _ node-input-infos second class>>
+ ^^box-displaced-alien
+ ] binary-op
] [ emit-primitive ] if ;
-:: inline-alien ( node quot test -- )
+:: inline-accessor ( node quot test -- )
node node-input-infos :> infos
infos test call
[ infos quot call ]
[ node emit-primitive ] if ; inline
-: inline-alien-getter? ( infos -- ? )
+: inline-load-memory? ( infos -- ? )
[ first class>> c-ptr class<= ]
[ second class>> fixnum class<= ]
bi and ;
-: ^^unbox-c-ptr ( src class -- dst )
- [ next-vreg dup ] 2dip ##unbox-c-ptr ;
+: prepare-accessor ( base offset info -- base offset )
+ class>> swap [ ^^unbox-c-ptr ] dip ^^add 0 ;
-: prepare-alien-accessor ( info -- ptr-vreg offset )
- class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
+: prepare-load-memory ( infos -- base offset )
+ [ 2inputs ] dip first prepare-accessor ;
-: prepare-alien-getter ( infos -- ptr-vreg offset )
- first prepare-alien-accessor ;
+: (emit-load-memory) ( node rep c-type quot -- )
+ '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ]
+ [ inline-load-memory? ]
+ inline-accessor ; inline
-: inline-alien-getter ( node quot -- )
- '[ prepare-alien-getter @ ds-push ]
- [ inline-alien-getter? ] inline-alien ; inline
+: emit-load-memory ( node rep c-type -- )
+ [ ] (emit-load-memory) ;
-: inline-alien-setter? ( infos class -- ? )
+: emit-alien-cell ( node -- )
+ int-rep f [ ^^box-alien ] (emit-load-memory) ;
+
+: inline-store-memory? ( infos class -- ? )
'[ first class>> _ class<= ]
[ second class>> c-ptr class<= ]
[ third class>> fixnum class<= ]
tri and and ;
-: prepare-alien-setter ( infos -- ptr-vreg offset )
- second prepare-alien-accessor ;
-
-: inline-alien-integer-setter ( node quot -- )
- '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
- [ fixnum inline-alien-setter? ]
- inline-alien ; inline
-
-: inline-alien-cell-setter ( node quot -- )
- '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
- [ pinned-c-ptr inline-alien-setter? ]
- inline-alien ; inline
-
-: inline-alien-float-setter ( node quot -- )
- '[ prepare-alien-setter ds-pop @ ]
- [ float inline-alien-setter? ]
- inline-alien ; inline
-
-: emit-alien-unsigned-getter ( node n -- )
- '[
- _ {
- { 1 [ ^^alien-unsigned-1 ] }
- { 2 [ ^^alien-unsigned-2 ] }
- { 4 [ ^^alien-unsigned-4 ] }
- } case ^^tag-fixnum
- ] inline-alien-getter ;
-
-: emit-alien-signed-getter ( node n -- )
- '[
- _ {
- { 1 [ ^^alien-signed-1 ] }
- { 2 [ ^^alien-signed-2 ] }
- { 4 [ ^^alien-signed-4 ] }
- } case ^^tag-fixnum
- ] inline-alien-getter ;
-
-: emit-alien-integer-setter ( node n -- )
- '[
- _ {
- { 1 [ ##set-alien-integer-1 ] }
- { 2 [ ##set-alien-integer-2 ] }
- { 4 [ ##set-alien-integer-4 ] }
- } case
- ] inline-alien-integer-setter ;
-
-: emit-alien-cell-getter ( node -- )
- [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
-
-: emit-alien-cell-setter ( node -- )
- [ ##set-alien-cell ] inline-alien-cell-setter ;
-
-: emit-alien-float-getter ( node rep -- )
- '[
- _ {
- { float-rep [ ^^alien-float ] }
- { double-rep [ ^^alien-double ] }
- } case
- ] inline-alien-getter ;
-
-: emit-alien-float-setter ( node rep -- )
- '[
- _ {
- { float-rep [ ##set-alien-float ] }
- { double-rep [ ##set-alien-double ] }
+: prepare-store-memory ( infos -- value base offset )
+ [ 3inputs ] dip second prepare-accessor ;
+
+:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- )
+ node
+ [ prepare-quot call rep c-type ##store-memory-imm ]
+ [ test-quot call inline-store-memory? ]
+ inline-accessor ; inline
+
+:: emit-store-memory ( node rep c-type -- )
+ node rep c-type
+ [ prepare-store-memory ]
+ [
+ rep {
+ { int-rep [ fixnum ] }
+ { float-rep [ float ] }
+ { double-rep [ float ] }
} case
- ] inline-alien-float-setter ;
+ ]
+ (emit-store-memory) ;
+
+: emit-set-alien-cell ( node -- )
+ int-rep f
+ [
+ [ first class>> ] [ prepare-store-memory ] bi
+ [ swap ^^unbox-c-ptr ] 2dip
+ ]
+ [ pinned-c-ptr ]
+ (emit-store-memory) ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math math.intervals
namespaces combinators fry arrays
cpu.architecture
compiler.tree.propagation.info
+compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
- 2inputs
- ^^or
- tag-mask get ^^and-imm
- 0 cc= ^^compare-imm
- ds-push ;
-
-: emit-fixnum-op ( insn -- )
- [ 2inputs ] dip call ds-push ; inline
+ [
+ [ ^^tagged>integer ] bi@
+ ^^or tag-mask get ^^and-imm
+ 0 cc= ^^compare-integer-imm
+ ] binary-op ;
: emit-fixnum-left-shift ( -- )
- [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+ [ ^^shl ] binary-op ;
: emit-fixnum-right-shift ( -- )
- [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
+ [
+ [ tag-bits get ^^shl-imm ] dip
+ ^^neg ^^sar
+ tag-bits get ^^sar-imm
+ ] binary-op ;
: emit-fixnum-shift-general ( -- )
- ds-peek 0 cc> ##compare-imm-branch
+ ds-peek 0 cc> ##compare-integer-imm-branch
[ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch
2array emit-conditional ;
[ drop emit-fixnum-shift-general ]
} cond ;
-: emit-fixnum-bitnot ( -- )
- ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
-
-: emit-fixnum-log2 ( -- )
- ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-
-: emit-fixnum*fast ( -- )
- 2inputs ^^untag-fixnum ^^mul ds-push ;
-
: emit-fixnum-comparison ( cc -- )
- '[ _ ^^compare ] emit-fixnum-op ;
+ '[ _ ^^compare-integer ] binary-op ;
: emit-no-overflow-case ( dst -- final-bb )
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
: emit-fixnum* ( -- )
- [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
+ [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats
+USING: fry kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
-: emit-float-op ( insn -- )
- [ 2inputs ] dip call ds-push ; inline
-
: emit-float-ordered-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+ '[ _ ^^compare-float-ordered ] binary-op ; inline
: emit-float-unordered-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
-
-: emit-float>fixnum ( -- )
- ds-pop ^^float>integer ^^tag-fixnum ds-push ;
-
-: emit-fixnum>float ( -- )
- ds-pop ^^untag-fixnum ^^integer>float ds-push ;
-
-: emit-fsqrt ( -- )
- ds-pop ^^sqrt ds-push ;
+ '[ _ ^^compare-float-unordered ] binary-op ; inline
: emit-unary-float-function ( func -- )
- [ ds-pop ] dip ^^unary-float-function ds-push ;
+ '[ _ ^^unary-float-function ] unary-op ;
: emit-binary-float-function ( func -- )
- [ 2inputs ] dip ^^binary-float-function ds-push ;
+ '[ _ ^^binary-float-function ] binary-op ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture assocs
compiler.cfg.hats
+compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.strings
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: alien
QUALIFIED: alien.accessors
+QUALIFIED: alien.c-types
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ math.private:fixnum- [ drop emit-fixnum- ] }
{ math.private:fixnum* [ drop emit-fixnum* ] }
- { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
- { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
- { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
- { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
- { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
- { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+ { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
+ { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
+ { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
+ { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
+ { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
+ { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
{ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
- { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
{ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
- { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+ { kernel:eq? [ emit-eq ] }
{ slots.private:slot [ emit-slot ] }
{ slots.private:set-slot [ emit-set-slot ] }
- { strings.private:string-nth [ drop emit-string-nth ] }
+ { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
{ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ arrays:<array> [ emit-<array> ] }
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ kernel:<wrapper> [ emit-simple-allot ] }
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
- { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
- { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
- { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
- { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
- { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
- { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
- { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
- { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
- { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
- { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
+ { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
+ { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
+ { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
+ { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
+ { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
+ { alien.accessors:alien-cell [ emit-alien-cell ] }
+ { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
} enable-intrinsics
: enable-alien-4-intrinsics ( -- )
{
- { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
- { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
- { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
- { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
+ { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
+ { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
+ { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
} enable-intrinsics ;
: enable-float-intrinsics ( -- )
{
- { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
- { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
- { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
- { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
+ { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
+ { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
+ { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
{ math.private:float< [ drop cc< emit-float-ordered-comparison ] }
{ math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
{ math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
{ math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
{ math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
{ math.private:float= [ drop cc= emit-float-unordered-comparison ] }
- { math.private:float>fixnum [ drop emit-float>fixnum ] }
- { math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
+ { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
{ math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
- { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
- { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
+ { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
+ { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
+ { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
{
- { math.libm:fsqrt [ drop emit-fsqrt ] }
+ { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
} enable-intrinsics ;
: enable-float-min/max ( -- )
{
- { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
- { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+ { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
+ { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
} enable-intrinsics ;
: enable-float-functions ( -- )
: enable-min/max ( -- )
{
- { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
- { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
+ { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
+ { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
} enable-intrinsics ;
-: enable-fixnum-log2 ( -- )
+: enable-log2 ( -- )
{
- { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel math accessors
-compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.hats compiler.cfg.instructions
+USING: accessors classes.algebra layouts kernel math namespaces
+sequences cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.stacks
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
compiler.cfg.builder.blocks
compiler.cfg.utilities ;
FROM: vm => context-field-offset vm-field-offset ;
+QUALIFIED-WITH: alien.c-types c
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
- ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+ [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
+
+: emit-eq ( node -- )
+ node-input-infos first2 [ class>> fixnum class<= ] both?
+ [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
: special-object-offset ( n -- offset )
cells "special-objects" vm-field-offset + ;
] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- )
- ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
- hashcode-shift ^^shr-imm
- ^^tag-fixnum
- ds-push ;
+ [
+ ^^tagged>integer
+ tag-mask get bitnot ^^load-integer ^^and
+ 0 int-rep f ^^load-memory-imm
+ hashcode-shift ^^shr-imm
+ ] unary-op ;
M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
-M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
+M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
unit-test
! vneg
-[ { ##load-constant ##sub-vector } ]
+[ { ##load-reference ##sub-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
[ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##add-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##sub-vector ##add-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
[ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
-[ { ##load-constant ##andn-vector } ]
+[ { ##load-reference ##andn-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
M: shuffle-cpu %shuffle-vector-reps signed-reps ;
! vshuffle-elements
-[ { ##load-constant ##shuffle-vector } ]
+[ { ##load-reference ##shuffle-vector } ]
[ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
[ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
-[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
+[ { ##load-reference ##xor-vector ##xor-vector ##compare-vector } ]
[ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
: ^load-neg-zero-vector ( rep -- dst )
{
- { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-literal ] }
} case ;
: ^load-add-sub-vector ( rep -- dst )
signed-rep {
- { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-constant ] }
- { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
- { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
- { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
- { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-literal ] }
+ { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-literal ] }
+ { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-literal ] }
} case ;
: ^load-half-vector ( rep -- dst )
{
- { float-4-rep [ float-array{ 0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ 0.5 0.5 } underlying>> ^^load-constant ] }
+ { float-4-rep [ float-array{ 0.5 0.5 0.5 0.5 } underlying>> ^^load-literal ] }
+ { double-2-rep [ double-array{ 0.5 0.5 } underlying>> ^^load-literal ] }
} case ;
: >variable-shuffle ( shuffle rep -- shuffle' )
'[ _ n*v _ v+ ] map concat ;
: ^load-immediate-shuffle ( shuffle rep -- dst )
- >variable-shuffle ^^load-constant ;
+ >variable-shuffle ^^load-literal ;
:: ^blend-vector ( mask true false rep -- dst )
true mask rep ^^and-vector
[ ^(compare-vector) ]
[ ^minmax-compare-vector ]
{ unsigned-int-vector-rep [| src1 src2 rep cc |
- rep sign-bit-mask ^^load-constant :> sign-bits
+ rep sign-bit-mask ^^load-literal :> sign-bits
src1 sign-bits rep ^^xor-vector
src2 sign-bits rep ^^xor-vector
rep signed-rep cc ^(compare-vector)
: emit-alien-vector ( node -- )
dup [
'[
- ds-drop prepare-alien-getter
- _ ^^alien-vector ds-push
+ ds-drop prepare-load-memory
+ _ f ^^load-memory-imm ds-push
]
- [ inline-alien-getter? ] inline-alien
+ [ inline-load-memory? ] inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: emit-set-alien-vector ( node -- )
dup [
'[
- ds-drop prepare-alien-setter ds-pop
- _ ##set-alien-vector
+ ds-drop prepare-store-memory
+ _ f ##store-memory-imm
]
- [ byte-array inline-alien-setter? ]
- inline-alien
+ [ byte-array inline-store-memory? ]
+ inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: enable-simd ( -- )
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
classes.algebra classes.builtin locals combinators
-cpu.architecture compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
+combinators.short-circuit cpu.architecture
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ;
-: ^^tag-offset>slot ( slot tag -- vreg' )
- [ ^^offset>slot ] dip ^^sub-imm ;
+: slot-indexing ( slot tag -- slot scale tag )
+ complex-addressing?
+ [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
: (emit-slot) ( infos -- dst )
[ 2inputs ] [ first value-tag ] bi*
- ^^tag-offset>slot ^^slot ;
+ slot-indexing ^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
: immediate-slot-offset? ( value-info -- ? )
literal>> {
- { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
- [ drop f ]
- } cond ;
+ [ fixnum? ]
+ [ cell * immediate-arithmetic? ]
+ } 1&& ;
: emit-slot ( node -- )
dup node-input-infos
:: (emit-set-slot) ( infos -- )
3inputs :> ( src obj slot )
- slot infos second value-tag ^^tag-offset>slot :> slot
+ infos second value-tag :> tag
- src obj slot ##set-slot
+ slot tag slot-indexing :> ( slot scale tag )
+ src obj slot scale tag ##set-slot
infos emit-write-barrier?
- [ obj slot next-vreg next-vreg ##write-barrier ] when ;
+ [ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
:: (emit-set-slot-imm) ( infos -- )
ds-drop
src obj slot tag ##set-slot-imm
infos emit-write-barrier?
- [ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
+ [ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
: emit-set-slot ( node -- )
dup node-input-infos
dup third immediate-slot-offset?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ drop emit-primitive ] if ;
-
-: emit-string-nth ( -- )
- 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
-
-: emit-set-string-nth-fast ( -- )
- 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
- swap next-vreg ##set-string-nth-fast ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel compiler.constants compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks cpu.architecture ;
+IN: compiler.cfg.intrinsics.strings
+
+: (string-nth) ( n string -- base offset rep c-type )
+ ^^tagged>integer swap ^^add string-offset int-rep uchar ; inline
+
+: emit-string-nth-fast ( -- )
+ 2inputs (string-nth) ^^load-memory-imm ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+ 3inputs (string-nth) ##store-memory-imm ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities locals
IN: compiler.cfg.linear-scan.allocation
: active-positions ( new assoc -- )
- [ vreg>> active-intervals-for ] dip
+ [ active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ;
: inactive-positions ( new assoc -- )
- [ [ vreg>> inactive-intervals-for ] keep ] dip
+ [ [ inactive-intervals-for ] keep ] dip
'[
[ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
_ add-use-position
! If the live interval has a usage at 'n', don't spill it,
! since this means its being defined by the sync point
! instruction. Output t if this is the case.
- 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+ 2dup [ uses>> ] dip '[ n>> _ = ] any?
+ [ 2drop t ] [ spill f ] if ;
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.
- [ [ heap-peek nip ] bi@ <= ] most ;
+ {
+ { [ dup heap-empty? ] [ drop ] }
+ { [ over heap-empty? ] [ nip ] }
+ [ [ [ heap-peek nip ] bi@ <= ] most ]
+ } cond ;
: (allocate-registers) ( -- )
- {
- { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
- { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
- ! If a live interval begins at the same location as a sync point,
- ! process the sync point before the live interval. This ensures that the
- ! return value of C function calls doesn't get spilled and reloaded
- ! unnecessarily.
- [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
- } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+ ! If a live interval begins at the same location as a sync point,
+ ! process the sync point before the live interval. This ensures that the
+ ! return value of C function calls doesn't get spilled and reloaded
+ ! unnecessarily.
+ unhandled-sync-points get unhandled-intervals get smallest-heap
+ dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting namespaces linked-assocs
] [ drop ] if ;
: trim-before-ranges ( live-interval -- )
- [ ranges>> ] [ uses>> last 1 + ] bi
+ [ ranges>> ] [ last-use n>> 1 + ] bi
[ '[ from>> _ <= ] filter! drop ]
[ swap last (>>to) ]
2bi ;
: trim-after-ranges ( live-interval -- )
- [ ranges>> ] [ uses>> first ] bi
+ [ ranges>> ] [ first-use n>> ] bi
[ '[ to>> _ >= ] filter! drop ]
[ swap first (>>from) ]
2bi ;
: assign-spill ( live-interval -- )
- dup vreg>> vreg-spill-slot >>spill-to drop ;
+ dup [ vreg>> ] [ last-use rep>> ] bi
+ assign-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
] if ;
: assign-reload ( live-interval -- )
- dup vreg>> vreg-spill-slot >>reload-from drop ;
+ dup [ vreg>> ] [ first-use rep>> ] bi
+ assign-spill-slot >>reload-from drop ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,
split-interval [ spill-before ] [ spill-after ] bi* ;
: find-use-position ( live-interval new -- n )
- [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+ [ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
+ [ n>> ] [ 1/0. ] if* ;
: find-use-positions ( live-intervals new assoc -- )
'[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
: active-positions ( new assoc -- )
- [ [ vreg>> active-intervals-for ] keep ] dip
+ [ [ active-intervals-for ] keep ] dip
find-use-positions ;
: inactive-positions ( new assoc -- )
[
- [ vreg>> inactive-intervals-for ] keep
+ [ inactive-intervals-for ] keep
[ '[ _ intervals-intersect? ] filter ] keep
] dip
find-use-positions ;
>alist alist-max ;
: spill-new? ( new pair -- ? )
- [ uses>> first ] [ second ] bi* > ;
+ [ first-use n>> ] [ second ] bi* > ;
: spill-new ( new pair -- )
drop spill-after add-unhandled ;
! If there is an active interval using 'reg' (there should be at
! most one) are split and spilled and removed from the inactive
! set.
- new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
+ new active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
'[ _ remove-nth! drop new start>> spill ] [ 2drop ] if ;
:: spill-intersecting-inactive ( new reg -- )
! Any inactive intervals using 'reg' are split and spilled
! and removed from the inactive set.
- new vreg>> inactive-intervals-for [
+ new inactive-intervals-for [
dup reg>> reg = [
dup new intervals-intersect? [
new start>> spill f
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting namespaces
] bi ;
: split-uses ( uses n -- before after )
- '[ _ <= ] partition ;
+ '[ n>> _ <= ] partition ;
ERROR: splitting-too-early ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math math.order namespaces sequences vectors
+USING: arrays accessors assocs combinators cpu.architecture fry
+heaps kernel math math.order namespaces sequences vectors
linked-assocs compiler.cfg compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
! Vector of active live intervals
SYMBOL: active-intervals
-: active-intervals-for ( vreg -- seq )
- rep-of reg-class-of active-intervals get at ;
+: active-intervals-for ( live-interval -- seq )
+ reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
- dup vreg>> active-intervals-for push ;
+ dup active-intervals-for push ;
: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for remove-eq! drop ;
+ dup active-intervals-for remove-eq! drop ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
-: inactive-intervals-for ( vreg -- seq )
- rep-of reg-class-of inactive-intervals get at ;
+: inactive-intervals-for ( live-interval -- seq )
+ reg-class>> inactive-intervals get at ;
: add-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for push ;
+ dup inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for remove-eq! drop ;
+ dup inactive-intervals-for remove-eq! drop ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: check-activate ( live-interval -- )
check-allocation? get [
- dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+ dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
[ register-already-used ] [ drop ] if
] [ drop ] if ;
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
-: next-spill-slot ( rep -- n )
- rep-size cfg get
+: next-spill-slot ( size -- n )
+ cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ;
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: vreg-spill-slot ( vreg -- spill-slot )
- spill-slots get [ rep-of next-spill-slot ] cache ;
+: assign-spill-slot ( coalesced-vreg rep -- spill-slot )
+ rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
+
+: lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+ rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
: init-allocator ( registers -- )
registers set
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> rep-of reg-class-of registers get at
+ reg-class>> registers get at
[ 1/0. ] H{ } <linked-assoc> map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals arrays
+fry make combinators combinators.short-circuit sets locals arrays
cpu.architecture layouts
compiler.cfg
compiler.cfg.def-use
compiler.cfg.liveness
+compiler.cfg.liveness.ssa
compiler.cfg.registers
compiler.cfg.instructions
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
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 ;
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
-ERROR: bad-vreg vreg ;
-
-: (vreg>reg) ( vreg pending -- reg )
+:: vreg>reg ( vreg -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
- ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
-
-: vreg>reg ( vreg -- reg )
- pending-interval-assoc get (vreg>reg) ;
+ vreg leader :> leader
+ leader pending-interval-assoc get at* [
+ drop leader vreg rep-of lookup-spill-slot
+ ] unless ;
: vregs>regs ( vregs -- assoc )
- dup assoc-empty? [
- pending-interval-assoc get
- '[ _ (vreg>reg) ] assoc-map
- ] unless ;
+ [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
+! Liveness info is used by resolve pass
+
! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+! on all incoming CFG edges
+SYMBOL: machine-live-ins
+
+: machine-live-in ( bb -- assoc )
+ machine-live-ins get at ;
+
+: compute-live-in ( bb -- )
+ [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
+
+! Mapping from basic blocks to predecessors to values which are
+! live on a particular incoming edge
+SYMBOL: machine-edge-live-ins
+
+: machine-edge-live-in ( predecessor bb -- assoc )
+ machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+ [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+ machine-edge-live-ins get set-at ;
! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+ machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+ [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
: init-assignment ( live-intervals -- )
<min-heap> pending-interval-heap set
H{ } clone pending-interval-assoc set
<min-heap> unhandled-intervals set
- H{ } clone register-live-ins set
- H{ } clone register-live-outs set
+ H{ } clone machine-live-ins set
+ H{ } clone machine-edge-live-ins set
+ H{ } clone machine-live-outs set
init-unhandled ;
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
+ [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
+ [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
+
+: insert-reload? ( live-interval -- ? )
+ ! Don't insert a reload if the register will be written to
+ ! before being read again.
+ {
+ [ reload-from>> ]
+ [ first-use type>> +use+ eq? ]
+ } 1&& ;
: handle-reload ( live-interval -- )
- dup reload-from>> [ insert-reload ] [ drop ] if ;
+ dup insert-reload? [ insert-reload ] [ drop ] if ;
: activate-interval ( live-interval -- )
[ add-pending ] [ handle-reload ] bi ;
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-: 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 [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
- ] assoc-each
- ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
- ! Outputs a sequence of { offset register/spill-slot } pairs
- [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
- ! Since ##gc is always the first instruction in a block, the set of
- ! values live at the ##gc is just live-in.
+M: ##call-gc assign-registers-in-insn
dup call-next-method
- basic-block get register-live-ins get at
- [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
- drop ;
+ [ [ vreg>reg ] map ] change-gc-roots drop ;
M: insn assign-registers-in-insn drop ;
: begin-block ( bb -- )
- dup basic-block set
- dup block-from activate-new-intervals
- [ live-in vregs>regs ] keep register-live-ins get set-at ;
-
-: end-block ( bb -- )
- [ live-out vregs>regs ] keep register-live-outs get set-at ;
-
-: vreg-at-start ( vreg bb -- state )
- register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
- register-live-outs get at ?at [ bad-vreg ] unless ;
+ {
+ [ basic-block set ]
+ [ block-from activate-new-intervals ]
+ [ compute-edge-live-in ]
+ [ compute-live-in ]
+ } cleave ;
:: assign-registers-in-block ( bb -- )
bb [
[ , ]
} cleave
] each
- bb end-block
+ bb compute-live-out
] V{ } make
] change-instructions drop ;
compiler.cfg.registers
compiler.cfg.predecessors
compiler.cfg.rpo
-compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.def-use
compiler.cfg.comparisons
[
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 0 }
{ end 2 }
- { uses V{ 0 1 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } }
{ ranges V{ T{ live-range f 0 2 } } }
{ spill-to T{ spill-slot f 0 } }
}
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 5 5 } } }
{ reload-from T{ spill-slot f 0 } }
}
] [
T{ live-interval
{ vreg 1 }
+ { reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ 0 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill
] unit-test
[
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 0 }
{ end 1 }
- { uses V{ 0 } }
+ { uses V{ T{ vreg-use f float-rep 0 } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 4 } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 1 }
{ end 5 }
- { uses V{ 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 1 5 } } }
{ reload-from T{ spill-slot f 4 } }
}
] [
T{ live-interval
{ vreg 2 }
+ { reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ 0 1 5 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill
] unit-test
[
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 0 }
{ end 1 }
- { uses V{ 0 } }
+ { uses V{ T{ vreg-use f float-rep 0 } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 8 } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 20 }
{ end 30 }
- { uses V{ 20 30 } }
+ { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ ranges V{ T{ live-range f 20 30 } } }
{ reload-from T{ spill-slot f 8 } }
}
] [
T{ live-interval
{ vreg 3 }
+ { reg-class float-regs }
{ start 0 }
{ end 30 }
- { uses V{ 0 20 30 } }
+ { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
] unit-test
V{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ 1 3 7 10 15 } }
+ { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ 3 4 8 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ reg 3 }
{ start 3 }
{ end 10 }
- { uses V{ 3 10 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } }
}
}
}
H{ } inactive-intervals set
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f int-rep 5 } } }
}
spill-status
] unit-test
V{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ 1 } }
+ { uses V{ T{ vreg-use f int-rep 1 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ 3 8 } }
+ { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } }
}
}
}
H{ } inactive-intervals set
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ 5 } }
+ { uses V{ T{ vreg-use f int-rep 5 } } }
}
spill-status
] unit-test
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ 0 10 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 11 }
{ end 20 }
- { uses V{ 11 20 } }
+ { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 11 20 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 60 }
- { uses V{ 30 60 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } }
{ ranges V{ T{ live-range f 30 60 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 200 }
- { uses V{ 30 200 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } }
{ ranges V{ T{ live-range f 30 200 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ 0 100 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 30 }
{ end 100 }
- { uses V{ 30 100 } }
+ { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } }
{ ranges V{ T{ live-range f 30 100 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ 0 10 20 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ 0 10 20 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 6 } }
+ { uses V{ T{ vreg-use f int-rep 6 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
{ vreg 4 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
! This guy will invoke the 'spill partially available' code path
T{ live-interval
{ vreg 5 }
+ { reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ 0 6 10 } }
+ { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
! This guy will invoke the 'spill new' code path
T{ live-interval
{ vreg 5 }
+ { reg-class int-regs }
{ start 2 }
{ end 8 }
- { uses V{ 8 } }
+ { uses V{ T{ vreg-use f int-rep 8 } } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
[ 5 ] [
T{ live-interval
{ start 0 }
+ { reg-class int-regs }
{ end 10 }
{ uses { 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ start 5 }
+ { reg-class int-regs }
{ end 10 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
{
T{ live-interval
{ vreg 1 }
+ { reg-class int-regs }
{ start 0 }
{ end 20 }
{ reg 0 }
T{ live-interval
{ vreg 2 }
+ { reg-class int-regs }
{ start 4 }
{ end 40 }
{ reg 0 }
{
T{ live-interval
{ vreg 3 }
+ { reg-class int-regs }
{ start 0 }
{ end 40 }
{ reg 1 }
} active-intervals set
T{ live-interval
- { vreg 4 }
+ { vreg 4 }
+ { reg-class int-regs }
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
- { uses V{ 8 10 } }
+ { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } }
}
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 703128 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 703129 }
- { loc D 0 }
- }
- T{ ##copy
- { dst 703134 }
- { src 703128 }
- }
- T{ ##copy
- { dst 703135 }
- { src 703129 }
- }
- T{ ##compare-imm-branch
- { src1 703128 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##copy
- { dst 703134 }
- { src 703129 }
- }
- T{ ##copy
- { dst 703135 }
- { src 703128 }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##replace
- { src 703134 }
- { loc D 0 }
- }
- T{ ##replace
- { src 703135 }
- { loc D 1 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 3 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 3 edge
-
-! Bug in inactive interval handling
-! [ rot dup [ -rot ] when ]
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek
- { dst 689473 }
- { loc D 2 }
- }
- T{ ##peek
- { dst 689474 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 689475 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 689473 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##copy
- { dst 689481 }
- { src 689475 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689482 }
- { src 689474 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689483 }
- { src 689473 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##copy
- { dst 689481 }
- { src 689473 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689482 }
- { src 689475 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689483 }
- { src 689474 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 689481 }
- { loc D 0 }
- }
- T{ ##replace
- { src 689482 }
- { loc D 1 }
- }
- T{ ##replace
- { src 689483 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Similar to the above
-! [ swap dup [ rot ] when ]
-
-T{ basic-block
- { id 201537 }
- { number 0 }
- { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
-
-V{
- T{ ##peek
- { dst 689600 }
- { loc D 1 }
- }
- T{ ##peek
- { dst 689601 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 689600 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##peek
- { dst 689604 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 689607 }
- { src 689604 }
- }
- T{ ##copy
- { dst 689608 }
- { src 689600 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689610 }
- { src 689601 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek
- { dst 689609 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 689607 }
- { src 689600 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689608 }
- { src 689601 }
- { rep int-rep }
- }
- T{ ##copy
- { dst 689610 }
- { src 689609 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 689607 }
- { loc D 0 }
- }
- T{ ##replace
- { src 689608 }
- { loc D 1 }
- }
- T{ ##replace
- { src 689610 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! compute-live-registers was inaccurate since it didn't take
-! lifetime holes into account
-
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek
- { dst 0 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 0 }
- { src2 5 }
- { cc cc/= }
- }
-} 1 test-bb
-
-V{
- T{ ##peek
- { dst 1 }
- { loc D 1 }
- }
- T{ ##copy
- { dst 2 }
- { src 1 }
- { rep int-rep }
- }
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##peek
- { dst 3 }
- { loc D 2 }
- }
- T{ ##copy
- { dst 2 }
- { src 3 }
- { rep int-rep }
- }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace
- { src 2 }
- { loc D 0 }
- }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Inactive interval handling: splitting active interval
-! if it fits in lifetime hole only partially
-
-V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 2 R 0 }
- T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##branch }
-} 2 test-bb
-
-
-V{
- 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 3 R 2 }
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Not until splitting is finished
-! [ _copy ] [ 3 get instructions>> second class ] unit-test
-
-! Resolve pass; make sure the spilling is done correctly
-V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 2 R 0 }
- T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
- T{ ##branch }
-} 2 test-bb
-
-V{
- 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 3 R 2 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
-
-[ _spill ] [ 3 get instructions>> second class ] unit-test
-
-[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
-
-[ _reload ] [ 4 get instructions>> first class ] unit-test
-
-! Resolve pass
-V{
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
- 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
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##peek f 1 D 0 }
- T{ ##compare-imm-branch f 1 5 cc= }
-} 4 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 5 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 6 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 4 edge
-3 4 edge
-4 { 5 6 } edges
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
-
-[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
-
-[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
-
-! A more complicated failure case with resolve that came up after the above
-! got fixed
-V{ T{ ##branch } } 0 test-bb
-V{
- 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 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 0 D 0 } T{ ##branch } } 5 test-bb
-V{ T{ ##return } } 6 test-bb
-V{ T{ ##branch } } 7 test-bb
-V{
- 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 1 D 1 }
- T{ ##replace f 2 D 2 }
- T{ ##replace f 3 D 3 }
- T{ ##return }
-} 9 test-bb
-
-0 1 edge
-1 { 2 7 } edges
-7 8 edge
-8 9 edge
-2 { 3 5 } edges
-3 4 edge
-4 9 edge
-5 6 edge
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-[ _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 [ dst>> n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> 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 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 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
-
-V{ T{ ##branch } } 3 test-bb
-
-V{
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Spilling an interval immediately after its activated;
-! and the interval does not have a use at the activation point
-V{
- 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 1 D 1 }
- T{ ##branch }
-} 2 test-bb
-
-V{
- 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 0 D 0 }
- T{ ##return }
-} 5 test-bb
-
-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
-
-! Reduction of push-all regression, x86-32
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##load-immediate { dst 61 } }
- T{ ##peek { dst 62 } { loc D 0 } }
- T{ ##peek { dst 64 } { loc D 1 } }
- T{ ##slot-imm
- { dst 69 }
- { obj 64 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
- T{ ##slot-imm
- { dst 85 }
- { obj 62 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##compare-branch
- { src1 69 }
- { src2 85 }
- { cc cc> }
- }
-} 1 test-bb
-
-V{
- T{ ##slot-imm
- { dst 97 }
- { obj 62 }
- { slot 2 }
- { tag 7 }
- }
- 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 98 } { loc R 0 } }
- T{ ##peek { dst 100 } { loc D 0 } }
- T{ ##set-slot-imm
- { src 100 }
- { obj 98 }
- { slot 2 }
- { tag 7 }
- }
- 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 } { rep int-rep } }
- T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
- T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
- T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
- T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
- T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
- T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
- T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
- T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
- T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
- T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
- T{ ##branch }
-} 4 test-bb
-
-V{
- 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
-
-0 1 edge
-1 { 2 4 } edges
-2 3 edge
-3 5 edge
-4 5 edge
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
-! Another reduction of push-all
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek { dst 85 } { loc D 0 } }
- T{ ##slot-imm
- { dst 89 }
- { obj 85 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##peek { dst 91 } { loc D 1 } }
- T{ ##slot-imm
- { dst 96 }
- { obj 91 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##add
- { dst 109 }
- { src1 89 }
- { src2 96 }
- }
- T{ ##slot-imm
- { dst 115 }
- { obj 85 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##slot-imm
- { dst 118 }
- { obj 115 }
- { slot 1 }
- { tag 2 }
- }
- T{ ##compare-branch
- { src1 109 }
- { src2 118 }
- { cc cc> }
- }
-} 1 test-bb
-
-V{
- T{ ##add-imm
- { dst 128 }
- { src1 109 }
- { src2 8 }
- }
- T{ ##load-immediate { dst 129 } { val 24 } }
- T{ ##inc-d { n 4 } }
- T{ ##inc-r { n 1 } }
- 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 134 } { loc D 1 } }
- T{ ##slot-imm
- { dst 140 }
- { obj 134 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n 1 } }
- 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 141 } { loc R 0 } }
- T{ ##peek { dst 143 } { loc D 0 } }
- T{ ##set-slot-imm
- { src 143 }
- { obj 141 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##write-barrier-imm
- { src 141 }
- { slot 2 }
- { temp1 145 }
- { temp2 146 }
- }
- T{ ##inc-d { n -1 } }
- T{ ##inc-r { n -1 } }
- 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 } { rep int-rep } }
- T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
- T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
- T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
- T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
- T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
- T{ ##branch }
-} 4 test-bb
-
-V{
- T{ ##inc-d { n 3 } }
- T{ ##inc-r { n 1 } }
- 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 163 }
- { obj 161 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n -1 } }
- 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
-
-0 1 edge
-1 { 2 5 } edges
-2 3 edge
-3 4 edge
-4 6 edge
-5 6 edge
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
-! Fencepost error in assignment pass
-V{ T{ ##branch } } 0 test-bb
-
-V{
- 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 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 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-! Another test case for fencepost error in assignment pass
-V{ T{ ##branch } } 0 test-bb
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
- 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
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
-
-[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
-
-[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
-
-[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-V{
- 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 2 3 }
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 2 test-bb
-
-0 1 edge
-1 2 edge
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-
-V{
- 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 2 3 }
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 1 test-bb
-
-V{
- T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
-compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+! SSA liveness must have been computed already
+
:: (linear-scan) ( cfg machine-registers -- )
- cfg compute-live-sets
cfg number-instructions
cfg compute-live-intervals machine-registers allocate-registers
cfg assign-registers
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! 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.linearization.order
-compiler.cfg ;
+USING: namespaces kernel assocs accessors locals sequences math
+math.order fry combinators binary-search
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.def-use
+compiler.cfg.liveness
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
+compiler.cfg
+cpu.architecture ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
C: <live-range> live-range
+SYMBOLS: +def+ +use+ +memory+ ;
+
+TUPLE: vreg-use rep n type ;
+
+C: <vreg-use> vreg-use
+
TUPLE: live-interval
vreg
reg spill-to reload-from
-start end ranges uses ;
+start end ranges uses
+reg-class ;
+
+: first-use ( live-interval -- use ) uses>> first ; inline
+
+: last-use ( live-interval -- use ) uses>> last ; inline
GENERIC: covers? ( insn# obj -- ? )
[ drop ] [ [ from>> <=> ] with search nip ] 2bi
covers?
] if ;
-
+
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-GENERIC: operands-in-registers? ( insn -- ? )
-
-M: vreg-insn operands-in-registers? drop t ;
-
-M: partial-sync-insn operands-in-registers? drop f ;
-
-: add-def ( insn live-interval -- )
- [ insn#>> ] [ uses>> ] bi* push ;
-
-: add-use ( insn live-interval -- )
- ! Every use is a potential def, no SSA here baby!
- over operands-in-registers? [ add-def ] [ 2drop ] if ;
+:: add-use ( rep n type live-interval -- )
+ type +memory+ eq? [
+ rep n type <vreg-use>
+ live-interval uses>> push
+ ] unless ;
-: <live-interval> ( vreg -- live-interval )
+: <live-interval> ( vreg reg-class -- live-interval )
\ live-interval new
V{ } clone >>uses
V{ } clone >>ranges
+ swap >>reg-class
swap >>vreg ;
: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
-M: live-interval hashcode*
- nip [ start>> ] [ end>> 1000 * ] bi + ;
+SYMBOLS: from to ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: live-interval ( vreg -- live-interval )
- live-intervals get [ <live-interval> ] cache ;
+ leader live-intervals get
+ [ dup rep-of reg-class-of <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
-: handle-output ( insn vreg -- )
- live-interval
- [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
+:: record-def ( vreg n type -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
-: handle-input ( insn vreg -- )
- live-interval
- [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
+ n live-interval shorten-range
+ rep n type live-interval add-use ;
-: handle-temp ( insn vreg -- )
- live-interval
- [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
+:: record-use ( vreg n type -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
-M: vreg-insn compute-live-intervals*
- [ dup defs-vreg [ handle-output ] with when* ]
- [ dup uses-vregs [ handle-input ] with each ]
- [ dup temp-vregs [ handle-temp ] with each ]
- tri ;
+ from get n live-interval add-range
+ rep n type live-interval add-use ;
+
+:: record-temp ( vreg n -- )
+ vreg rep-of :> rep
+ vreg live-interval :> live-interval
+
+ n n live-interval add-range
+ rep n +def+ live-interval add-use ;
+
+M:: vreg-insn compute-live-intervals* ( insn -- )
+ insn insn#>> :> n
+
+ insn defs-vreg [ n +def+ record-def ] when*
+ insn uses-vregs [ n +use+ record-use ] each
+ insn temp-vregs [ n record-temp ] each ;
+
+M:: clobber-insn compute-live-intervals* ( insn -- )
+ insn insn#>> :> n
+
+ insn defs-vreg [ n +use+ record-def ] when*
+ insn uses-vregs [ n +memory+ record-use ] each
+ insn temp-vregs [ n record-temp ] each ;
: handle-live-out ( bb -- )
- [ block-from ] [ block-to ] [ live-out keys ] tri
- [ live-interval add-range ] with with each ;
+ live-out dup assoc-empty? [ drop ] [
+ [ from get to get ] dip keys
+ [ live-interval add-range ] with with each
+ ] if ;
! A location where all registers have to be spilled
TUPLE: sync-point n ;
GENERIC: compute-sync-points* ( insn -- )
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
- [ basic-block set ]
- [ handle-live-out ]
- [
- instructions>> <reversed> [
- [ compute-live-intervals* ]
- [ compute-sync-points* ]
- bi
- ] each
- ] tri ;
+ {
+ [ block-from from set ]
+ [ block-to to set ]
+ [ handle-live-out ]
+ [
+ instructions>> <reversed> [
+ [ compute-live-intervals* ]
+ [ compute-sync-points* ]
+ bi
+ ] each
+ ]
+ } cleave ;
: init-live-intervals ( -- )
H{ } clone live-intervals set
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.linearization.order ;
+compiler.cfg.linearization ;
IN: compiler.cfg.linear-scan.numbering
ERROR: already-numbered insn ;
[
{
- { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
+ {
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ T{ location f 1 int-rep int-regs }
+ }
}
] [
[
[
{
- T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
+ T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
}
] [
[
- { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ T{ location f 1 int-rep int-regs }
+ >insn
] { } make
] unit-test
[
{
- T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+ T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
}
] [
[
- { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
+ T{ location f 1 int-rep int-regs }
+ T{ location f T{ spill-slot f 0 } int-rep int-regs }
+ >insn
] { } make
] unit-test
}
] [
[
- { 1 int-rep } { 2 int-rep } >insn
+ T{ location f 1 int-rep int-regs }
+ T{ location f 2 int-rep int-regs }
+ >insn
] { } make
] unit-test
-cfg new 8 >>spill-area-size cfg set
-H{ } clone spill-temps set
+[
+ {
+ T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+ T{ ##branch }
+ }
+] [
+ { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
+ mapping-instructions
+] unit-test
[
- t
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+ T{ ##branch }
+ }
] [
- { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
+ {
+ { T{ location f T{ spill-slot f 1 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 0 } int-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+[
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
+ }
+] [
+ {
+ { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+[
+ {
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+ T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
+ }
+] [
+ {
+ { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+ { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+ }
+ mapping-instructions
+] unit-test
+
+cfg new 8 >>spill-area-size cfg set
+H{ } clone spill-temps set
+
+[ t ] [
+ {
+ { T{ location f 0 int-rep int-regs } T{ location f 1 int-rep int-regs } }
+ { T{ location f 1 int-rep int-regs } T{ location f 0 int-rep int-regs } }
+ }
mapping-instructions {
{
- T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+ T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
- T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
{
- T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+ T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
- T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
} member?
] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
+cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.parallel-copy
+compiler.cfg.ssa.destruction
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve
+TUPLE: location
+{ reg read-only }
+{ rep read-only }
+{ reg-class read-only } ;
+
+: <location> ( reg rep -- location )
+ dup reg-class-of location boa ;
+
+M: location equal?
+ over location? [
+ { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
+ ] [ 2drop f ] if ;
+
+M: location hashcode*
+ reg>> hashcode* ;
+
SYMBOL: spill-temps
: spill-temp ( rep -- n )
- spill-temps get [ next-spill-slot ] cache ;
+ rep-size spill-temps get [ next-spill-slot ] cache ;
: add-mapping ( from to rep -- )
- '[ _ 2array ] bi@ 2array , ;
+ '[ _ <location> ] bi@ 2array , ;
-:: resolve-value-data-flow ( bb to vreg -- )
- vreg bb vreg-at-end
- vreg to vreg-at-start
+:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
+ vreg live-out ?at [ bad-vreg ] unless
+ vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
-: compute-mappings ( bb to -- mappings )
- dup live-in dup assoc-empty? [ 3drop f ] [
- [ keys [ resolve-value-data-flow ] with with each ] { } make
+:: compute-mappings ( bb to -- mappings )
+ bb machine-live-out :> live-out
+ to machine-live-in :> live-in
+ bb to machine-edge-live-in :> edge-live-in
+ live-out assoc-empty? [ f ] [
+ [
+ live-in keys edge-live-in keys append [
+ live-out live-in edge-live-in
+ resolve-value-data-flow
+ ] each
+ ] { } make
] if ;
: memory->register ( from to -- )
- swap [ first2 ] [ first ] bi* _reload ;
+ swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ;
: register->memory ( from to -- )
- [ first2 ] [ first ] bi* _spill ;
+ [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ;
: temp->register ( from to -- )
- nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
+ nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ;
: register->temp ( from to -- )
- drop [ first2 ] [ second spill-temp ] bi _spill ;
+ drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ;
: register->register ( from to -- )
- swap [ first ] [ first2 ] bi* ##copy ;
+ swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
SYMBOL: temp
{
{ [ over temp eq? ] [ temp->register ] }
{ [ dup temp eq? ] [ register->temp ] }
- { [ over first spill-slot? ] [ memory->register ] }
- { [ dup first spill-slot? ] [ register->memory ] }
+ { [ over reg>> spill-slot? ] [ memory->register ] }
+ { [ dup reg>> spill-slot? ] [ register->memory ] }
[ register->register ]
} cond ;
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as
- [ temp [ swap >insn ] parallel-mapping ] { } make ;
+ [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions insert-simple-basic-block
+ mapping-instructions insert-basic-block
cfg get cfg-changed drop
] if ;
--- /dev/null
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+kernel accessors sequences sets tools.test namespaces ;
+IN: compiler.cfg.linearization.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals layouts hashtables
-cpu.architecture generalizations
-compiler.cfg
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
+USING: accessors arrays assocs deques dlists hashtables kernel
+make sorting namespaces sequences combinators
+combinators.short-circuit fry math compiler.cfg.rpo
+compiler.cfg.utilities compiler.cfg.loop-detection
+compiler.cfg.predecessors sets hash-sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.linearization
-<PRIVATE
-
-SYMBOL: numbers
-
-: block-number ( bb -- n ) numbers get at ;
-
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
-
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
-
-: linearize-basic-block ( bb -- )
- [ block-number _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
- ! If our successor immediately follows us in linearization
- ! order then we don't need to branch.
- [ block-number ] bi@ 1 - = ; inline
-
-: emit-branch ( bb successor -- )
- 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
-
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
-
-: successors ( bb -- first second ) successors>> first2 ; inline
-
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
- bb insn
- conditional-quot
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap block-number ] n ndip ]
- [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
-
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- 3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
- [ dup successors ]
- [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
-
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
- 4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-M: ##compare-branch linearize-insn
- binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-imm-branch linearize-insn
- binary-conditional _compare-imm-branch emit-branch ;
-
-M: ##compare-float-ordered-branch linearize-insn
- binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
- binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
- test-vector-conditional _test-vector-branch emit-branch ;
+<PRIVATE
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors block-number ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+SYMBOLS: work-list loop-heads visited ;
+
+: visited? ( bb -- ? ) visited get in? ;
+
+: add-to-work-list ( bb -- )
+ dup visited? [ drop ] [
+ work-list get push-back
+ ] if ;
+
+: init-linearization-order ( cfg -- )
+ <dlist> work-list set
+ HS{ } clone visited set
+ entry>> add-to-work-list ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+ dup {
+ [ predecessor visited? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor successors>> length 1 = ]
+ [ [ number>> ] [ predecessor number>> ] bi > ]
+ } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
+
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
+
+: process-successor ( bb -- )
+ dup predecessors-ready? [
+ dup loop-entry? [ find-alternate-loop-head ] when
+ add-to-work-list
+ ] [ drop ] if ;
+
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
+
+: process-block ( bb -- )
+ dup visited? [ drop ] [
+ [ , ]
+ [ visited get adjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri
+ ] if ;
+
+: (linearization-order) ( cfg -- bbs )
+ init-linearization-order
+
+ [ work-list get [ process-block ] slurp-deque ] { } make
+ ! [ unlikely?>> not ] partition append
+ ;
-M: ##fixnum-add linearize-insn
- overflow-conditional _fixnum-add emit-branch ;
+PRIVATE>
-M: ##fixnum-sub linearize-insn
- overflow-conditional _fixnum-sub emit-branch ;
+: linearization-order ( cfg -- bbs )
+ needs-post-order needs-loops needs-predecessors
-M: ##fixnum-mul linearize-insn
- overflow-conditional _fixnum-mul emit-branch ;
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if ;
-M: ##dispatch linearize-insn
- swap
- [ [ src>> ] [ temp>> ] bi _dispatch ]
- [ successors>> [ block-number _dispatch-label ] each ]
- bi* ;
+SYMBOL: numbers
-: linearize-basic-blocks ( cfg -- insns )
- [
- [
- linearization-order
- [ number-blocks ]
- [ [ linearize-basic-block ] each ] bi
- ] [ spill-area-size>> _spill-area-size ] bi
- ] { } make ;
+: block-number ( bb -- n ) numbers get at ;
-PRIVATE>
-
-: flatten-cfg ( cfg -- mr )
- [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
- <mr> ;
+: number-blocks ( bbs -- )
+ [ 2array ] map-index >hashtable numbers set ;
+++ /dev/null
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
-kernel accessors sequences sets tools.test namespaces ;
-IN: compiler.cfg.linearization.order.tests
-
-V{ } 0 test-bb
-
-V{ } 1 test-bb
-
-V{ } 2 test-bb
-
-0 { 1 1 } edges
-1 2 edge
-
-[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make sorting
-namespaces sequences combinators combinators.short-circuit
-fry math compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors
-sets hash-sets ;
-FROM: namespaces => set ;
-IN: compiler.cfg.linearization.order
-
-! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
-
-<PRIVATE
-
-SYMBOLS: work-list loop-heads visited ;
-
-: visited? ( bb -- ? ) visited get in? ;
-
-: add-to-work-list ( bb -- )
- dup visited? [ drop ] [
- work-list get push-back
- ] if ;
-
-: init-linearization-order ( cfg -- )
- <dlist> work-list set
- HS{ } clone visited set
- entry>> add-to-work-list ;
-
-: (find-alternate-loop-head) ( bb -- bb' )
- dup {
- [ predecessor visited? not ]
- [ predecessors>> length 1 = ]
- [ predecessor successors>> length 1 = ]
- [ [ number>> ] [ predecessor number>> ] bi > ]
- } 1&& [ predecessor (find-alternate-loop-head) ] when ;
-
-: find-back-edge ( bb -- pred )
- [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-
-: find-alternate-loop-head ( bb -- bb' )
- dup find-back-edge dup visited? [ drop ] [
- nip (find-alternate-loop-head)
- ] if ;
-
-: predecessors-ready? ( bb -- ? )
- [ predecessors>> ] keep '[
- _ 2dup back-edge?
- [ 2drop t ] [ drop visited? ] if
- ] all? ;
-
-: process-successor ( bb -- )
- dup predecessors-ready? [
- dup loop-entry? [ find-alternate-loop-head ] when
- add-to-work-list
- ] [ drop ] if ;
-
-: sorted-successors ( bb -- seq )
- successors>> <reversed> [ loop-nesting-at ] sort-with ;
-
-: process-block ( bb -- )
- dup visited? [ drop ] [
- [ , ]
- [ visited get adjoin ]
- [ sorted-successors [ process-successor ] each ]
- tri
- ] if ;
-
-: (linearization-order) ( cfg -- bbs )
- init-linearization-order
-
- [ work-list get [ process-block ] slurp-deque ] { } make ;
-
-PRIVATE>
-
-: linearization-order ( cfg -- bbs )
- needs-post-order needs-loops needs-predecessors
-
- dup linear-order>> [ ] [
- dup (linearization-order)
- >>linear-order linear-order>>
- ] ?if ;
+++ /dev/null
-Flattening CFG into MR (machine representation)
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.liveness arrays sequences assocs
+compiler.cfg.registers kernel namespaces tools.test ;
+IN: compiler.cfg.liveness.ssa.tests
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 0 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-integer f 1 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##replace f 2 D 0 }
+ T{ ##branch }
+} 6 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 7 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
+5 6 edge
+6 7 edge
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test
+
+[ t ] [ 0 get live-in assoc-empty? ] unit-test
+
+[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test
+
+[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
+
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 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
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
! is in correspondence with a predecessor
-SYMBOL: phi-live-ins
+SYMBOL: edge-live-ins
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
SYMBOL: work-list
: compute-live-in ( basic-block -- live-in )
[ live-out ] keep instructions>> transfer-liveness ;
-: compute-phi-live-in ( basic-block -- phi-live-in )
+: compute-edge-live-in ( basic-block -- edge-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 ]
+ [ [ compute-edge-live-in ] keep edge-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
+ [ dup successors>> [ edge-live-in ] with map ] bi
append assoc-combine ;
: update-live-out ( basic-block -- changed? )
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
needs-predecessors
<hashed-dlist> work-list set
H{ } clone live-ins set
- H{ } clone phi-live-ins set
+ H{ } clone edge-live-ins set
H{ } clone live-outs set
- dup post-order add-to-work-list
+ post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+: current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;
+
: needs-loops ( cfg -- cfg' )
needs-predecessors
dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame ;
-IN: compiler.cfg.mr
-
-: build-mr ( cfg -- mr )
- insert-gc-checks
- insert-save-contexts
- linear-scan
- flatten-cfg
- build-stack-frame ;
\ No newline at end of file
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators namespaces
-compiler.cfg.tco
+USING: compiler.cfg.tco
compiler.cfg.useless-conditionals
compiler.cfg.branch-splitting
compiler.cfg.block-joining
+compiler.cfg.height
compiler.cfg.ssa.construction
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.copy-prop
compiler.cfg.dce
-compiler.cfg.write-barrier
-compiler.cfg.representations
-compiler.cfg.ssa.destruction
-compiler.cfg.empty-blocks
-compiler.cfg.checker ;
+compiler.cfg.write-barrier ;
IN: compiler.cfg.optimizer
-SYMBOL: check-optimizer?
-
-: ?check ( cfg -- cfg' )
- check-optimizer? get [
- dup check-cfg
- ] when ;
-
: optimize-cfg ( cfg -- cfg' )
optimize-tail-calls
delete-useless-conditionals
split-branches
join-blocks
+ normalize-height
construct-ssa
alias-analysis
value-numbering
copy-propagation
eliminate-dead-code
- eliminate-write-barriers
- select-representations
- destruct-ssa
- delete-empty-blocks
- ?check ;
+ eliminate-write-barriers ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel parser assocs sequences ;
+USING: accessors namespaces kernel math parser assocs sequences ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs, are just integers
! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
! an ##inc-d 1 becomes D 1 after ##inc-d 1.
-TUPLE: loc { n read-only } ;
+TUPLE: loc { n integer read-only } ;
TUPLE: ds-loc < loc ;
C: <ds-loc> ds-loc
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: arrays sequences kernel namespaces accessors compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.debugger
+compiler.cfg.representations.coalescing
+tools.test ;
+IN: compiler.cfg.representations.coalescing.tests
+
+: test-scc ( -- )
+ cfg new 0 get >>entry compute-components ;
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 2 D 0 }
+ T{ ##load-integer f 0 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 1 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 0 } { 2 1 } } }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-scc ] unit-test
+
+[ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
+[ t ] [ 0 vreg>scc 3 vreg>scc = ] unit-test
+[ f ] [ 2 vreg>scc 3 vreg>scc = ] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
+kernel namespaces sequences ;
+IN: compiler.cfg.representations.coalescing
+
+! Find all strongly connected components in the graph where the
+! edges are ##phi or ##copy vreg uses
+SYMBOL: components
+
+: init-components ( cfg components -- )
+ '[
+ instructions>> [
+ defs-vreg [ _ add-atom ] when*
+ ] each
+ ] each-basic-block ;
+
+GENERIC# visit-insn 1 ( insn disjoint-set -- )
+
+M: ##copy visit-insn
+ [ [ dst>> ] [ src>> ] bi ] dip equate ;
+
+M: ##phi visit-insn
+ [ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
+
+M: insn visit-insn 2drop ;
+
+: merge-components ( cfg components -- )
+ '[
+ instructions>> [
+ _ visit-insn
+ ] each
+ ] each-basic-block ;
+
+: compute-components ( cfg -- )
+ <disjoint-set>
+ [ init-components ]
+ [ merge-components ]
+ [ components set drop ] 2tri ;
+
+: vreg>scc ( vreg -- scc )
+ components get representative ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays combinators compiler.cfg.instructions
+compiler.cfg.registers compiler.constants cpu.architecture
+kernel layouts locals math namespaces ;
+IN: compiler.cfg.representations.conversion
+
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: rep>tagged ( dst src rep -- )
+GENERIC: tagged>rep ( dst src rep -- )
+
+M: int-rep rep>tagged ( dst src rep -- )
+ drop tag-bits get ##shl-imm ;
+
+M: int-rep tagged>rep ( dst src rep -- )
+ drop tag-bits get ##sar-imm ;
+
+M:: float-rep rep>tagged ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src ##single>double-float
+ dst temp double-rep rep>tagged ;
+
+M:: float-rep tagged>rep ( dst src rep -- )
+ double-rep next-vreg-rep :> temp
+ temp src double-rep tagged>rep
+ dst temp ##double>single-float ;
+
+M:: double-rep rep>tagged ( dst src rep -- )
+ dst 16 float int-rep next-vreg-rep ##allot
+ src dst float-offset double-rep f ##store-memory-imm ;
+
+M: double-rep tagged>rep
+ drop float-offset double-rep f ##load-memory-imm ;
+
+M:: vector-rep rep>tagged ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
+ temp 16 tag-fixnum ##load-tagged
+ temp dst 1 byte-array type-number ##set-slot-imm
+ src dst byte-array-offset rep f ##store-memory-imm ;
+
+M: vector-rep tagged>rep
+ [ byte-array-offset ] dip f ##load-memory-imm ;
+
+M:: scalar-rep rep>tagged ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ temp src rep ##scalar>integer
+ dst temp int-rep rep>tagged ;
+
+M:: scalar-rep tagged>rep ( dst src rep -- )
+ tagged-rep next-vreg-rep :> temp
+ temp src int-rep tagged>rep
+ dst temp rep ##integer>scalar ;
+
+GENERIC: rep>int ( dst src rep -- )
+GENERIC: int>rep ( dst src rep -- )
+
+M: scalar-rep rep>int ( dst src rep -- )
+ ##scalar>integer ;
+
+M: scalar-rep int>rep ( dst src rep -- )
+ ##integer>scalar ;
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+ {
+ { [ 2dup eq? ] [ drop ##copy ] }
+ { [ dup tagged-rep? ] [ drop tagged>rep ] }
+ { [ over tagged-rep? ] [ nip rep>tagged ] }
+ { [ dup int-rep? ] [ drop int>rep ] }
+ { [ over int-rep? ] [ nip rep>int ] }
+ [
+ 2dup 2array {
+ { { double-rep float-rep } [ 2drop ##single>double-float ] }
+ { { float-rep double-rep } [ 2drop ##double>single-float ] }
+ ! Punning SIMD vector types? Naughty naughty! But
+ ! it is allowed... otherwise bail out.
+ [
+ drop 2dup [ reg-class-of ] bi@ eq?
+ [ drop ##copy ] [ bad-conversion ] if
+ ]
+ } case
+ ]
+ } cond ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators
+combinators.short-circuit kernel layouts locals make math
+namespaces sequences cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.selection ;
+IN: compiler.cfg.representations.peephole
+
+! Representation selection performs some peephole optimizations
+! when inserting conversions to optimize for a few common cases
+
+GENERIC: optimize-insn ( insn -- )
+
+SYMBOL: insn-index
+
+: here ( -- )
+ building get length 1 - insn-index set ;
+
+: finish ( insn -- ) , here ;
+
+: unchanged ( insn -- )
+ [ no-use-conversion ] [ finish ] [ no-def-conversion ] tri ;
+
+: last-insn ( -- insn ) insn-index get building get nth ;
+
+M: vreg-insn conversions-for-insn
+ init-renaming-set
+ optimize-insn
+ last-insn perform-renaming ;
+
+M: vreg-insn optimize-insn
+ [ emit-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;
+
+M: ##load-integer optimize-insn
+ {
+ {
+ [ dup dst>> rep-of tagged-rep? ]
+ [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! When a float is unboxed, we replace the ##load-reference with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+ {
+ [ drop fused-unboxing? ]
+ [ dst>> rep-of double-rep? ]
+ [ obj>> float? ]
+ } 1&& ;
+
+: convert-to-load-vector? ( insn -- ? )
+ {
+ [ drop fused-unboxing? ]
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> byte-array? ]
+ } 1&& ;
+
+! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
+ } 1&& ;
+
+: convert-to-fill-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
+ } 1&& ;
+
+M: ##load-reference optimize-insn
+ {
+ {
+ [ dup convert-to-load-double? ]
+ [ [ dst>> ] [ obj>> ] bi ##load-double here ]
+ }
+ {
+ [ dup convert-to-zero-vector? ]
+ [ dst>> dup rep-of ##zero-vector here ]
+ }
+ {
+ [ dup convert-to-fill-vector? ]
+ [ dst>> dup rep-of ##fill-vector here ]
+ }
+ {
+ [ dup convert-to-load-vector? ]
+ [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##shl-imm dst temp X
+! Into either
+! ##shl-imm by X - tag-bits, or
+! ##sar-imm by tag-bits - X.
+: combine-shl-imm-input ( insn -- )
+ [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
+ { [ 2dup < ] [ swap - ##sar-imm here ] }
+ { [ 2dup > ] [ - ##shl-imm here ] }
+ [ 2drop int-rep ##copy here ]
+ } cond ;
+
+: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
+: src1-tagged? ( insn -- ? ) src1>> rep-of tagged-rep? ;
+: src2-tagged? ( insn -- ? ) src2>> rep-of tagged-rep? ;
+
+: src2-tagged-arithmetic? ( insn -- ? ) src2>> tag-fixnum immediate-arithmetic? ;
+: src2-tagged-bitwise? ( insn -- ? ) src2>> tag-fixnum immediate-bitwise? ;
+: src2-tagged-shift-count? ( insn -- ? ) src2>> tag-bits get + immediate-shift-count? ;
+
+: >tagged-shift ( insn -- ) [ tag-bits get + ] change-src2 finish ; inline
+
+M: ##shl-imm optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ]
+ [ unchanged ]
+ }
+ {
+ [ dup { [ dst-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+ [ [ emit-use-conversion ] [ >tagged-shift ] [ no-def-conversion ] tri ]
+ }
+ {
+ [ dup src1-tagged? ]
+ [ [ no-use-conversion ] [ combine-shl-imm-input ] [ emit-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##sar-imm dst temp X
+! Into
+! ##sar-imm by X + tag-bits
+! assuming X + tag-bits is a valid shift count.
+M: ##sar-imm optimize-insn
+ {
+ {
+ [ dup { [ src1-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+ [ [ no-use-conversion ] [ >tagged-shift ] [ emit-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Peephole optimization: for X = add, sub, and, or, xor, min, max
+! we have
+! tag(untag(a) X untag(b)) = a X b
+!
+! so if all inputs and outputs of ##X or ##X-imm are tagged,
+! don't have to insert any conversions
+M: inert-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged? ] } 1&& ]
+ [ unchanged ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! -imm variant of above
+: >tagged-imm ( insn -- )
+ [ tag-fixnum ] change-src2 unchanged ; inline
+
+M: inert-arithmetic-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ]
+ [ >tagged-imm ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+M: inert-bitwise-tag-untag-insn optimize-insn
+ {
+ {
+ [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ]
+ [ >tagged-imm ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+M: ##mul-imm optimize-insn
+ {
+ { [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ] [ unchanged ] }
+ { [ dup { [ dst-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+! Similar optimization for comparison operators
+M: ##compare-integer-imm optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer-imm-branch optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+ [ call-next-method ]
+ } cond ;
+
+M: ##compare-integer-branch optimize-insn
+ {
+ { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+ [ call-next-method ]
+ } cond ;
+
+! Identities:
+! tag(neg(untag(x))) = x
+! tag(neg(x)) = x * -2^tag-bits
+: inert-tag/untag-unary? ( insn -- ? )
+ [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
+
+: combine-neg-tag ( insn -- )
+ [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ;
+
+M: ##neg optimize-insn
+ {
+ { [ dup inert-tag/untag-unary? ] [ unchanged ] }
+ {
+ [ dup dst>> rep-of tagged-rep? ]
+ [ [ emit-use-conversion ] [ combine-neg-tag ] [ no-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+! Identity:
+! tag(not(untag(x))) = not(x) xor tag-mask
+:: emit-tagged-not ( insn -- )
+ tagged-rep next-vreg-rep :> temp
+ temp insn src>> ##not
+ insn dst>> temp tag-mask get ##xor-imm here ;
+
+M: ##not optimize-insn
+ {
+ {
+ [ dup inert-tag/untag-unary? ]
+ [ [ no-use-conversion ] [ emit-tagged-not ] [ no-def-conversion ] tri ]
+ }
+ [ call-next-method ]
+ } cond ;
: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
-: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
'[
[ basic-block set ] [
[
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.representations.preferred cpu.architecture kernel
-namespaces tools.test sequences arrays system ;
+namespaces tools.test sequences arrays system literals layouts
+math compiler.constants compiler.cfg.representations.conversion
+compiler.cfg.representations.rewrite
+compiler.cfg.comparisons
+make ;
IN: compiler.cfg.representations
[ { double-rep double-rep } ] [
] unit-test
[ double-rep ] [
- T{ ##alien-double
+ T{ ##load-memory-imm
{ dst 5 }
- { src 3 }
+ { base 3 }
+ { offset 0 }
+ { rep double-rep }
} defs-vreg-rep
] unit-test
+H{ } clone representations set
+
+3 \ vreg-counter set-global
+
+[
+ {
+ T{ ##allot f 2 16 float 4 }
+ T{ ##store-memory-imm f 1 2 $[ float-offset ] double-rep f }
+ }
+] [
+ [
+ 2 1 tagged-rep double-rep emit-conversion
+ ] { } make
+] unit-test
+
+[
+ {
+ T{ ##load-memory-imm f 2 1 $[ float-offset ] double-rep f }
+ }
+] [
+ [
+ 2 1 double-rep tagged-rep emit-conversion
+ ] { } make
+] unit-test
+
: test-representations ( -- )
cfg new 0 get >>entry dup cfg set select-representations drop ;
[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+! Don't dereference the result of a peek
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##add-float f 2 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##add-float f 3 1 1 }
+ T{ ##replace f 3 D 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 3 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! We cannot untag-fixnum the result of a peek if there are usages
+! of it as a tagged-rep
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##replace f 1 R 0 }
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##mul f 2 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if all usages use
+! it as int-rep
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+V{
+ T{ ##add f 2 1 1 }
+ T{ ##mul f 3 1 1 }
+ T{ ##replace f 2 D 0 }
+ T{ ##replace f 3 D 1 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+3 \ vreg-counter set-global
+
+[ ] [ test-representations ] unit-test
+
+[
+ V{
+ T{ ##peek f 4 D 0 }
+ T{ ##sar-imm f 1 4 $[ tag-bits get ] }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+! scalar-rep => int-rep conversion
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##vector>scalar f 3 2 int-4-rep }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
+
+! Test phi node behavior
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##load-integer f 1 1 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-integer f 2 2 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+ T{ ##replace f 3 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 1 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+[ T{ ##load-tagged f 2 $[ 2 tag-fixnum ] } ]
+[ 2 get instructions>> first ]
+unit-test
+
+! ##load-reference corner case
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-reference f 3 f }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f 4 H{ { 1 2 } { 2 3 } } }
+ T{ ##replace f 4 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+! Don't untag the f!
+[ 2 ] [ 2 get instructions>> length ] unit-test
+
cpu x86.32? [
! Make sure load-constant is converted into load-double
V{
T{ ##peek f 1 D 0 }
- T{ ##load-constant f 2 0.5 }
+ T{ ##load-reference f 2 0.5 }
T{ ##add-float f 3 1 2 }
T{ ##replace f 3 D 0 }
T{ ##branch }
V{
T{ ##peek f 1 D 0 }
- T{ ##compare-imm-branch f 1 2 }
+ T{ ##compare-imm-branch f 1 2 cc= }
} 1 test-bb
V{
- T{ ##load-constant f 2 1.5 }
+ T{ ##load-reference f 2 1.5 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##load-constant f 3 2.5 }
+ T{ ##load-reference f 3 2.5 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##phi f 4 }
+ T{ ##phi f 4 H{ { 2 2 } { 3 3 } } }
T{ ##peek f 5 D 0 }
T{ ##add-float f 6 4 5 }
T{ ##replace f 6 D 0 }
test-diamond
4 5 edge
- 2 get 2 2array
- 3 get 3 2array 2array 4 get instructions>> first (>>inputs)
-
[ ] [ test-representations ] unit-test
[ t ] [ 2 get instructions>> first ##load-double? ] unit-test
[ t ] [ 3 get instructions>> first ##load-double? ] unit-test
[ t ] [ 4 get instructions>> first ##phi? ] unit-test
-] when
\ No newline at end of file
+] when
+
+: test-peephole ( insns -- insns )
+ 0 test-bb
+ test-representations
+ 0 get instructions>> ;
+
+! Don't convert the def site into anything but tagged-rep since
+! we might lose precision
+5 \ vreg-counter set-global
+
+[ f ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-float f 3 0 0 }
+ T{ ##store-memory-imm f 3 2 0 float-rep f }
+ T{ ##store-memory-imm f 3 2 4 float-rep f }
+ T{ ##mul-float f 4 0 0 }
+ T{ ##replace f 4 D 0 }
+ } test-peephole
+ [ ##single>double-float? ] any?
+] unit-test
+
+! Converting a ##load-integer into a ##load-tagged
+[
+ V{
+ T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if input to ##shl-imm is tagged
+3 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 2 1 1 }
+ T{ ##add f 4 2 2 }
+ T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 3 }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+3 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 $[ 10 tag-bits get - ] }
+ T{ ##add f 4 2 2 }
+ T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 10 }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##copy f 2 1 int-rep }
+ T{ ##add f 5 2 2 }
+ T{ ##shl-imm f 3 5 $[ tag-bits get ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 $[ tag-bits get ] }
+ T{ ##add f 3 2 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if output of ##shl-imm needs to be tagged
+[
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##shl-imm f 2 1 $[ 3 tag-bits get + ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##load-integer f 1 100 }
+ T{ ##shl-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Peephole optimization if both input and output of ##shl-imm
+! needs to be tagged
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 3 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 3 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+6 \ vreg-counter set-global
+
+! Peephole optimization if input to ##sar-imm is tagged
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 7 1 $[ 3 tag-bits get + ] }
+ T{ ##shl-imm f 2 7 $[ tag-bits get ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##sar-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##add-imm f 2 1 $[ 100 tag-fixnum ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##add-imm f 2 1 100 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add f 2 0 1 }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+! Make sure we don't exceed immediate bounds
+cpu x86.64? [
+ 4 \ vreg-counter set-global
+
+ [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 5 0 $[ tag-bits get ] }
+ T{ ##add-imm f 6 5 $[ 30 2^ ] }
+ T{ ##shl-imm f 2 6 $[ tag-bits get ] }
+ T{ ##replace f 2 D 0 }
+ }
+ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 2 0 $[ 30 2^ ] }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+ ] unit-test
+
+ [
+ V{
+ T{ ##load-integer f 0 100 }
+ T{ ##mul-imm f 7 0 $[ 30 2^ ] }
+ T{ ##shl-imm f 1 7 $[ tag-bits get ] }
+ T{ ##replace f 1 D 0 }
+ }
+ ] [
+ V{
+ T{ ##load-integer f 0 100 }
+ T{ ##mul-imm f 1 0 $[ 30 2^ ] }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+ ] unit-test
+] when
+
+! Tag/untag elimination for ##mul-imm
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##mul-imm f 1 0 100 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##mul-imm f 1 0 100 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sar-imm f 5 1 $[ tag-bits get ] }
+ T{ ##add-imm f 2 5 30 }
+ T{ ##mul-imm f 3 2 $[ 100 tag-fixnum ] }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 30 }
+ T{ ##mul-imm f 3 2 100 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##compare-integer
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer f 2 0 1 cc= }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer f 2 0 1 cc= }
+ T{ ##replace f 2 D 0 }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-branch f 0 1 cc= }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-branch f 0 1 cc= }
+ } test-peephole
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm-branch f 0 $[ 10 tag-fixnum ] cc= }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm-branch f 0 10 cc= }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##neg
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 5 D 0 }
+ T{ ##sar-imm f 0 5 $[ tag-bits get ] }
+ T{ ##peek f 6 D 1 }
+ T{ ##sar-imm f 1 6 $[ tag-bits get ] }
+ T{ ##mul f 2 0 1 }
+ T{ ##mul-imm f 3 2 -16 }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##mul f 2 0 1 }
+ T{ ##neg f 3 2 }
+ T{ ##replace f 3 D 0 }
+ } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##not
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 3 0 }
+ T{ ##xor-imm f 1 3 $[ tag-mask get ] }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##replace f 1 D 0 }
+ } test-peephole
+] unit-test
\ No newline at end of file
! Copyright (C) 2009, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators combinators.short-circuit math make locals
-deques dlists layouts byte-arrays cpu.architecture
-compiler.utilities
-compiler.constants
+USING: combinators
compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.hats
compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.def-use
-compiler.cfg.utilities
+compiler.cfg.predecessors
compiler.cfg.loop-detection
-compiler.cfg.renaming.functor
-compiler.cfg.representations.preferred ;
-FROM: namespaces => set ;
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.peephole
+compiler.cfg.representations.selection
+compiler.cfg.representations.coalescing ;
IN: compiler.cfg.representations
-! Virtual register representation selection.
-
-ERROR: bad-conversion dst src dst-rep src-rep ;
-
-GENERIC: emit-box ( dst src rep -- )
-GENERIC: emit-unbox ( dst src rep -- )
-
-M:: float-rep emit-box ( dst src rep -- )
- double-rep next-vreg-rep :> temp
- temp src ##single>double-float
- dst temp double-rep emit-box ;
-
-M:: float-rep emit-unbox ( dst src rep -- )
- double-rep next-vreg-rep :> temp
- temp src double-rep emit-unbox
- dst temp ##double>single-float ;
-
-M: double-rep emit-box
- drop
- [ drop 16 float int-rep next-vreg-rep ##allot ]
- [ float-offset swap ##set-alien-double ]
- 2bi ;
-
-M: double-rep emit-unbox
- drop float-offset ##alien-double ;
-
-M:: vector-rep emit-box ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
- temp 16 tag-fixnum ##load-immediate
- temp dst 1 byte-array type-number ##set-slot-imm
- dst byte-array-offset src rep ##set-alien-vector ;
-
-M: vector-rep emit-unbox
- [ byte-array-offset ] dip ##alien-vector ;
-
-M:: scalar-rep emit-box ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- temp src rep ##scalar>integer
- dst temp tag-bits get ##shl-imm ;
-
-M:: scalar-rep emit-unbox ( dst src rep -- )
- int-rep next-vreg-rep :> temp
- temp src tag-bits get ##sar-imm
- dst temp rep ##integer>scalar ;
-
-: emit-conversion ( dst src dst-rep src-rep -- )
- {
- { [ 2dup eq? ] [ drop ##copy ] }
- { [ dup int-rep eq? ] [ drop emit-unbox ] }
- { [ over int-rep eq? ] [ nip emit-box ] }
- [
- 2dup 2array {
- { { double-rep float-rep } [ 2drop ##single>double-float ] }
- { { float-rep double-rep } [ 2drop ##double>single-float ] }
- ! Punning SIMD vector types? Naughty naughty! But
- ! it is allowed... otherwise bail out.
- [
- drop 2dup [ reg-class-of ] bi@ eq?
- [ drop ##copy ] [ bad-conversion ] if
- ]
- } case
- ]
- } cond ;
-
-<PRIVATE
-
-! For every vreg, compute possible representations.
-SYMBOL: possibilities
-
-: possible ( vreg -- reps ) possibilities get at ;
-
-: compute-possibilities ( cfg -- )
- H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
- [ members ] assoc-map possibilities set ;
-
-! Compute vregs which must remain tagged for their lifetime.
-SYMBOL: always-boxed
-
-:: (compute-always-boxed) ( vreg rep assoc -- )
- rep int-rep eq? [
- int-rep vreg assoc set-at
- ] when ;
-
-: compute-always-boxed ( cfg -- assoc )
- H{ } clone [
- '[
- [
- dup [ ##load-reference? ] [ ##load-constant? ] bi or
- [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
- ] each-non-phi
- ] each-basic-block
- ] keep ;
-
-! For every vreg, compute the cost of keeping it in every possible
-! representation.
-
-! Cost map maps vreg to representation to cost.
-SYMBOL: costs
-
-: init-costs ( -- )
- possibilities get [ drop H{ } clone ] assoc-map costs set ;
-
-: record-possibility ( rep vreg -- )
- costs get at [ 0 or ] change-at ;
-
-: increase-cost ( rep vreg -- )
- ! Increase cost of keeping vreg in rep, making a choice of rep less
- ! likely.
- costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
-
-: maybe-increase-cost ( possible vreg preferred -- )
- pick eq? [ record-possibility ] [ 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 ;
-
-GENERIC: compute-insn-costs ( insn -- )
-
-M: ##load-constant compute-insn-costs
- ! There's no cost to unboxing the result of a ##load-constant
- drop ;
-
-M: insn compute-insn-costs [ representation-cost ] each-rep ;
-
-: compute-costs ( cfg -- costs )
- init-costs
- [
- [ basic-block set ]
- [
- [
- compute-insn-costs
- ] each-non-phi
- ] bi
- ] each-basic-block
- costs get ;
-
-! For every vreg, compute preferred representation, that minimizes costs.
-: minimize-costs ( costs -- representations )
- [ nip assoc-empty? not ] assoc-filter
- [ >alist alist-min first ] assoc-map ;
-
-: compute-representations ( cfg -- )
- [ compute-costs minimize-costs ]
- [ compute-always-boxed ]
- bi assoc-union
- representations set ;
-
-! PHI nodes require special treatment
-! 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: phis
-
-: collect-phis ( cfg -- )
- H{ } clone phis set
- [
- phis get
- '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
- ] each-basic-block ;
-
-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 ( -- )
- phis get keys rep-assigned add-to-work-list ;
-
-: process-phi ( 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 phis get at* [
- [ rep-of ] [ rep-not-assigned ] bi*
- [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
- ] [ 2drop ] if ;
-
-: remaining-phis ( -- )
- phis get keys rep-not-assigned { } assert-sequence= ;
-
-: process-phis ( -- )
- <hashed-dlist> work-list set
- add-ready-phis
- work-list get [ process-phi ] slurp-deque
- remaining-phis ;
-
-: compute-phi-representations ( cfg -- )
- collect-phis process-phis ;
-
-! Insert conversions. This introduces new temporaries, so we need
-! to rename opearands too.
-
-! Mapping from vreg,rep pairs to vregs
-SYMBOL: alternatives
-
-:: 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.
- preferred required eq? [ src ] [
- src required alternatives get [
- required next-vreg-rep :> new-src
- [ new-src ] 2dip preferred emit-conversion
- new-src
- ] 2cache
- ] if ;
-
-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 -- new-vreg ) -- )
- 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! drop
- [ convert-insn-uses ] [ convert-insn-defs ] bi
- renaming-set get length 0 assert=
- ] [ drop ] if ;
-
-GENERIC: conversions-for-insn ( insn -- )
-
-M: ##phi conversions-for-insn , ;
-
-! When a float is unboxed, we replace the ##load-constant with a ##load-double
-! if the architecture supports it
-: convert-to-load-double? ( insn -- ? )
- {
- [ drop load-double? ]
- [ dst>> rep-of double-rep? ]
- [ obj>> float? ]
- } 1&& ;
-
-! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
-! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
-: convert-to-zero-vector? ( insn -- ? )
- {
- [ dst>> rep-of vector-rep? ]
- [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
- } 1&& ;
-
-: convert-to-fill-vector? ( insn -- ? )
- {
- [ dst>> rep-of vector-rep? ]
- [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
- } 1&& ;
-
-: (convert-to-load-double) ( insn -- dst val )
- [ dst>> ] [ obj>> ] bi ; inline
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
- dst>> dup rep-of ; inline
-
-: conversions-for-load-insn ( insn -- ?insn )
- {
- {
- [ dup convert-to-load-double? ]
- [ (convert-to-load-double) ##load-double f ]
- }
- {
- [ dup convert-to-zero-vector? ]
- [ (convert-to-zero/fill-vector) ##zero-vector f ]
- }
- {
- [ dup convert-to-fill-vector? ]
- [ (convert-to-zero/fill-vector) ##fill-vector f ]
- }
- [ ]
- } cond ;
-
-M: ##load-reference conversions-for-insn
- conversions-for-load-insn [ call-next-method ] when* ;
-
-M: ##load-constant conversions-for-insn
- conversions-for-load-insn [ call-next-method ] when* ;
-
-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 ] [
- [
- [
- H{ } clone alternatives set
- [ conversions-for-insn ] each
- ] V{ } make
- ] change-instructions drop
- ] if ;
-
-: insert-conversions ( cfg -- )
- [ conversions-for-block ] each-basic-block ;
-
-PRIVATE>
+! Virtual register representation selection. This is where
+! decisions about integer tagging and float and vector boxing
+! are made. The appropriate conversion operations inserted
+! after a cost analysis.
: select-representations ( cfg -- cfg' )
needs-loops
+ needs-predecessors
{
+ [ compute-components ]
[ compute-possibilities ]
[ compute-representations ]
- [ compute-phi-representations ]
[ insert-conversions ]
[ ]
- } cleave
- representations get cfg get (>>reps) ;
+ } cleave ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit layouts kernel locals make math
+namespaces sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.renaming.functor
+compiler.cfg.representations.conversion
+compiler.cfg.representations.preferred
+compiler.cfg.rpo
+compiler.cfg.utilities
+cpu.architecture ;
+IN: compiler.cfg.representations.rewrite
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+! Mapping from vreg,rep pairs to vregs
+SYMBOL: alternatives
+
+:: (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.
+ preferred required eq? [ src ] [
+ src required alternatives get [
+ required next-vreg-rep :> new-src
+ [ new-src ] 2dip preferred emit-conversion
+ new-src
+ ] 2cache
+ ] if ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+ needs-renaming? off
+ renaming-set get delete-all ;
+
+: 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 -- new-vreg ) -- )
+ vreg rep-of :> preferred
+ preferred required eq?
+ [ vreg no-renaming ]
+ [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: emit-use-conversion ( insn -- )
+ [ [ (emit-use-conversion) ] (compute-renaming-set) ] each-use-rep ;
+
+: no-use-conversion ( insn -- )
+ [ drop no-renaming ] each-use-rep ;
+
+: emit-def-conversion ( insn -- )
+ [ [ (emit-def-conversion) ] (compute-renaming-set) ] each-def-rep ;
+
+: no-def-conversion ( insn -- )
+ [ drop no-renaming ] each-def-rep ;
+
+: 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! drop
+ [ convert-insn-uses ] [ convert-insn-defs ] bi
+ renaming-set get length 0 assert=
+ ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+M: ##phi conversions-for-insn , ;
+
+M: ##copy conversions-for-insn , ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+ dup kill-block? [ drop ] [
+ [
+ [
+ H{ } clone alternatives set
+ [ conversions-for-insn ] each
+ ] V{ } make
+ ] change-instructions drop
+ ] if ;
+
+: insert-conversions ( cfg -- )
+ V{ } clone renaming-set set
+ [ conversions-for-block ] each-basic-block ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays combinators
+disjoint-sets fry kernel locals math namespaces sequences sets
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.loop-detection
+compiler.cfg.registers
+compiler.cfg.representations.preferred
+compiler.cfg.representations.coalescing
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.utilities
+cpu.architecture ;
+FROM: namespaces => set ;
+IN: compiler.cfg.representations.selection
+
+! vregs which must be tagged at the definition site because
+! there is at least one usage that is not int-rep. If all usages
+! are int-rep it is safe to untag at the definition site.
+SYMBOL: tagged-vregs
+
+SYMBOL: vreg-reps
+
+: handle-def ( vreg rep -- )
+ swap vreg>scc vreg-reps get
+ [ [ intersect ] when* ] change-at ;
+
+: handle-use ( vreg rep -- )
+ int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
+
+GENERIC: (collect-vreg-reps) ( insn -- )
+
+M: ##load-reference (collect-vreg-reps)
+ [ dst>> ] [ obj>> ] bi {
+ { [ dup float? ] [ drop { float-rep double-rep } ] }
+ { [ dup byte-array? ] [ drop vector-reps ] }
+ [ drop { } ]
+ } cond handle-def ;
+
+M: vreg-insn (collect-vreg-reps)
+ [ [ handle-use ] each-use-rep ]
+ [ [ 1array handle-def ] each-def-rep ]
+ [ [ 1array handle-def ] each-temp-rep ]
+ tri ;
+
+M: insn (collect-vreg-reps) drop ;
+
+: collect-vreg-reps ( cfg -- )
+ H{ } clone vreg-reps set
+ HS{ } clone tagged-vregs set
+ [ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
+
+SYMBOL: possibilities
+
+: possible-reps ( vreg reps -- vreg reps )
+ { tagged-rep } union
+ 2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
+ [ drop { tagged-rep int-rep } ] [ ] if ;
+
+: compute-possibilities ( cfg -- )
+ collect-vreg-reps
+ vreg-reps get [ possible-reps ] assoc-map possibilities set ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+ ! Initialize cost as 0 for each possibility.
+ possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: 10^ ( n -- x ) 10 <repetition> product ;
+
+: increase-cost ( rep scc factor -- )
+ ! Increase cost of keeping vreg in rep, making a choice of rep less
+ ! likely. If the rep is not in the cost alist, it means this
+ ! representation is prohibited.
+ [ costs get at 2dup key? ] dip
+ '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
+
+:: increase-costs ( vreg preferred factor -- )
+ vreg vreg>scc :> scc
+ scc possibilities get at [
+ dup preferred eq? [ drop ] [ scc factor increase-cost ] if
+ ] each ; inline
+
+UNION: inert-tag-untag-insn
+##add
+##sub
+##and
+##or
+##xor
+##min
+##max ;
+
+UNION: inert-arithmetic-tag-untag-insn
+##add-imm
+##sub-imm ;
+
+UNION: inert-bitwise-tag-untag-insn
+##and-imm
+##or-imm
+##xor-imm ;
+
+GENERIC: has-peephole-opts? ( insn -- ? )
+
+M: insn has-peephole-opts? drop f ;
+M: ##load-integer has-peephole-opts? drop t ;
+M: ##load-reference has-peephole-opts? drop t ;
+M: ##neg has-peephole-opts? drop t ;
+M: ##not has-peephole-opts? drop t ;
+M: inert-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
+M: ##mul-imm has-peephole-opts? drop t ;
+M: ##shl-imm has-peephole-opts? drop t ;
+M: ##shr-imm has-peephole-opts? drop t ;
+M: ##sar-imm has-peephole-opts? drop t ;
+M: ##compare-integer-imm has-peephole-opts? drop t ;
+M: ##compare-integer has-peephole-opts? drop t ;
+M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
+M: ##compare-integer-branch has-peephole-opts? drop t ;
+
+GENERIC: compute-insn-costs ( insn -- )
+
+M: insn compute-insn-costs drop ;
+
+M: vreg-insn compute-insn-costs
+ dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
+
+: compute-costs ( cfg -- )
+ init-costs
+ [
+ [ basic-block set ]
+ [ [ compute-insn-costs ] each-non-phi ] bi
+ ] each-basic-block ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+ [ nip assoc-empty? not ] assoc-filter
+ [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+ compute-costs costs get minimize-costs
+ [ components get [ disjoint-set-members ] keep ] dip
+ '[ dup _ representative _ at ] H{ } map>assoc
+ representations set ;
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
- dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
+ '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
dup post-order drop ;
: needs-save-context? ( insns -- ? )
[
{
+ [ ##call-gc? ]
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
: insert-save-context ( bb -- )
dup instructions>> dup needs-save-context? [
- int-rep next-vreg-rep
- int-rep next-vreg-rep
+ tagged-rep next-vreg-rep
+ tagged-rep next-vreg-rep
\ ##save-context new-insn prefix
>>instructions drop
] [ 2drop ] if ;
--- /dev/null
+USING: compiler.cfg.scheduling vocabs.loader namespaces tools.test ;
+IN: compiler.cfg.scheduling.tests
+
+! Recompile compiler.cfg.scheduling with extra tests,
+! and see if any errors come up. Back when there were
+! errors of this kind, they always surfaced this way.
+
+t check-scheduling? [
+ [ ] [ "compiler.cfg.scheduling" reload ] unit-test
+ [ ] [ "compiler.cfg.dependence" reload ] unit-test
+] with-variable
--- /dev/null
+! Copyright (C) 2009, 2010 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs compiler.cfg.def-use
+compiler.cfg.dependence compiler.cfg.instructions
+compiler.cfg.liveness compiler.cfg.rpo cpu.architecture fry
+kernel locals make math namespaces sequences sets ;
+IN: compiler.cfg.scheduling
+
+! Instruction scheduling to reduce register pressure, from:
+! "Register-sensitive selection, duplication, and
+! sequencing of instructions"
+! by Vivek Sarkar, et al.
+! http://portal.acm.org/citation.cfm?id=377849
+
+ERROR: bad-delete-at key assoc ;
+
+: check-delete-at ( key assoc -- )
+ 2dup key? [ delete-at ] [ bad-delete-at ] if ;
+
+: set-parent-indices ( node -- )
+ children>> building get length
+ '[ _ >>parent-index drop ] each ;
+
+: remove-node ( node -- )
+ [ follows>> members ] keep
+ '[ [ precedes>> _ swap check-delete-at ] each ]
+ [ [ ready? ] filter roots get push-all ] bi ;
+
+: score ( insn -- n )
+ [ parent-index>> ] [ registers>> neg ] [ insn>> insn#>> ] tri 3array ;
+
+: pull-out-nth ( n seq -- elt )
+ [ nth ] [ remove-nth! drop ] 2bi ;
+
+: select ( vector quot -- elt )
+ ! This could be sped up by a constant factor
+ [ dup <enum> ] dip '[ _ call( insn -- score ) ] assoc-map
+ dup values supremum '[ nip _ = ] assoc-find
+ 2drop swap pull-out-nth ; inline
+
+: select-instruction ( -- insn/f )
+ roots get [ f ] [
+ [ score ] select
+ [ insn>> ]
+ [ set-parent-indices ]
+ [ remove-node ] tri
+ ] if-empty ;
+
+: (reorder) ( -- )
+ select-instruction [
+ , (reorder)
+ ] when* ;
+
+: cut-by ( seq quot -- before after )
+ dupd find drop [ cut ] [ f ] if* ; inline
+
+UNION: initial-insn
+ ##phi ##inc-d ##inc-r ;
+
+: split-3-ways ( insns -- first middle last )
+ [ initial-insn? not ] cut-by unclip-last ;
+
+: reorder ( insns -- insns' )
+ split-3-ways [
+ build-dependence-graph
+ build-fan-in-trees
+ [ (reorder) ] V{ } make reverse
+ ] dip suffix append ;
+
+ERROR: not-all-instructions-were-scheduled old-bb new-bb ;
+
+SYMBOL: check-scheduling?
+f check-scheduling? set-global
+
+:: check-instructions ( new-bb old-bb -- )
+ new-bb old-bb [ instructions>> ] bi@
+ [ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and
+ [ old-bb new-bb not-all-instructions-were-scheduled ] unless ;
+
+ERROR: definition-after-usage vreg old-bb new-bb ;
+
+:: check-usages ( new-bb old-bb -- )
+ HS{ } clone :> useds
+ new-bb instructions>> split-3-ways drop nip
+ [| insn |
+ insn uses-vregs [ useds adjoin ] each
+ insn defs-vreg :> def-reg
+ def-reg useds in?
+ [ def-reg old-bb new-bb definition-after-usage ] when
+ ] each ;
+
+: check-scheduling ( new-bb old-bb -- )
+ [ check-instructions ] [ check-usages ] 2bi ;
+
+: with-scheduling-check ( bb quot: ( bb -- ) -- )
+ check-scheduling? get [
+ over dup clone
+ [ call( bb -- ) ] 2dip
+ check-scheduling
+ ] [
+ call( bb -- )
+ ] if ; inline
+
+: number-insns ( insns -- )
+ [ >>insn# drop ] each-index ;
+
+: clear-numbers ( insns -- )
+ [ f >>insn# drop ] each ;
+
+: schedule-block ( bb -- )
+ [
+ [
+ [ number-insns ]
+ [ reorder ]
+ [ clear-numbers ] tri
+ ] change-instructions drop
+ ] with-scheduling-check ;
+
+! Really, instruction scheduling should be aware that there are
+! multiple types of registers, but this number is just used
+! to decide whether to schedule instructions
+: num-registers ( -- x ) int-regs machine-registers at length ;
+
+: might-spill? ( bb -- ? )
+ [ live-in assoc-size ]
+ [ instructions>> [ defs-vreg ] count ] bi
+ + num-registers >= ;
+
+: schedule-instructions ( cfg -- cfg' )
+ dup [
+ dup might-spill?
+ [ schedule-block ]
+ [ drop ] if
+ ] each-basic-block ;
reset-counters
V{
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer 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 3 3 }
+ T{ ##load-integer f 3 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##load-immediate f 3 4 }
+ T{ ##load-integer f 3 4 }
T{ ##branch }
} 2 test-bb
[
V{
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 1 50 }
T{ ##add-imm f 3 2 10 }
T{ ##branch }
[
V{
- T{ ##load-immediate f 4 3 }
+ T{ ##load-integer f 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f 5 4 }
+ T{ ##load-integer f 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals fry sequences
cpu.architecture
compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.representations ;
+compiler.cfg.instructions ;
IN: compiler.cfg.ssa.cssa
! Convert SSA to conventional SSA. This pass runs after representation
:: insert-copy ( bb src rep -- bb dst )
bb src insert-copy? [
rep next-vreg-rep :> dst
- bb [ dst src rep src rep-of emit-conversion ] add-instructions
+ bb [ dst src rep ##copy ] add-instructions
bb dst
] [ bb src ] if ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry kernel namespaces
sequences sequences.deep
sets vectors
+cpu.architecture
compiler.cfg.rpo
compiler.cfg.def-use
-compiler.cfg.renaming
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
FROM: namespaces => set ;
IN: compiler.cfg.ssa.destruction
-! Maps vregs to leaders.
+! Because of the design of the register allocator, this pass
+! has three peculiar properties.
+!
+! 1) Instead of renaming vreg usages in the CFG, a map from
+! vregs to canonical representatives is computed. This allows
+! the register allocator to use the original SSA names to get
+! reaching definitions.
+! 2) Useless ##copy instructions, and all ##phi instructions,
+! are eliminated, so the register allocator does not have to
+! remove any redundant operations.
+! 3) A side effect of running this pass is that SSA liveness
+! information is computed, so the register allocator does not
+! need to compute it again.
+
SYMBOL: leader-map
: leader ( vreg -- vreg' ) leader-map get compress-path ;
: class-elements ( vreg -- elts ) class-element-map get at ;
+<PRIVATE
+
! Sequence of vreg pairs
SYMBOL: copies
: init-coalescing ( -- )
- H{ } clone leader-map set
- H{ } clone class-element-map set
+ defs get keys
+ [ [ dup ] H{ } map>assoc leader-map set ]
+ [ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
V{ } clone copies set ;
: classes-interfere? ( vreg1 vreg2 -- ? )
2bi
] if ;
-: introduce-vreg ( vreg -- )
- [ leader-map get conjoin ]
- [ [ 1vector ] keep class-element-map get set-at ] bi ;
-
GENERIC: prepare-insn ( insn -- )
: try-to-coalesce ( dst src -- ) 2array copies get push ;
M: insn prepare-insn
- [ defs-vreg ] [ uses-vregs ] bi
- 2dup empty? not and [
- first
- 2dup [ rep-of ] bi@ eq?
- [ try-to-coalesce ] [ 2drop ] if
- ] [ 2drop ] if ;
+ [ temp-vregs [ leader-map get conjoin ] each ]
+ [
+ [ defs-vreg ] [ uses-vregs ] bi
+ 2dup empty? not and [
+ first
+ 2dup [ rep-of reg-class-of ] bi@ eq?
+ [ try-to-coalesce ] [ 2drop ] if
+ ] [ 2drop ] if
+ ] bi ;
M: ##copy prepare-insn
[ dst>> ] [ src>> ] bi try-to-coalesce ;
+M: ##tagged>integer prepare-insn
+ [ dst>> ] [ src>> ] bi eliminate-copy ;
+
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
: prepare-coalescing ( cfg -- )
init-coalescing
- defs get keys [ introduce-vreg ] each
[ prepare-block ] each-basic-block ;
: process-copies ( -- )
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
-: useless-copy? ( ##copy -- ? )
- dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+GENERIC: useful-insn? ( insn -- ? )
-: perform-renaming ( cfg -- )
- leader-map get keys [ dup leader ] H{ } map>assoc renamings set
- [
- instructions>> [
- [ rename-insn-defs ]
- [ rename-insn-uses ]
- [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
- ] filter! drop
- ] each-basic-block ;
+: useful-copy? ( insn -- ? )
+ [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
+
+M: ##copy useful-insn? useful-copy? ;
+
+M: ##tagged>integer useful-insn? useful-copy? ;
+
+M: ##phi useful-insn? drop f ;
+
+M: insn useful-insn? drop t ;
+
+: cleanup-cfg ( cfg -- )
+ [ [ useful-insn? ] filter! ] simple-optimization ;
+
+PRIVATE>
: destruct-ssa ( cfg -- cfg' )
needs-dominance
dup construct-cssa
dup compute-defs
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-live-ranges
dup prepare-coalescing
process-copies
- dup perform-renaming ;
+ dup cleanup-cfg ;
: test-interference ( -- )
cfg new 0 get >>entry
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-defs
compute-live-ranges ;
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test namespaces sequences vectors accessors sets
-arrays math.ranges assocs
-cpu.architecture
-compiler.cfg
-compiler.cfg.ssa.liveness.private
-compiler.cfg.ssa.liveness
-compiler.cfg.debugger
-compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.registers
-compiler.cfg.dominance
-compiler.cfg.def-use ;
-IN: compiler.cfg.ssa.liveness
-
-[ t ] [ { 1 } 1 only? ] unit-test
-[ t ] [ { } 1 only? ] unit-test
-[ 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 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 3 D 0 }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ test-liveness ] unit-test
-
-[ H{ } ] [ back-edge-targets get ] 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
-
-: 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
-
-[ 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 ] [ 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 ] [ 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 ] [ 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 ] [ 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 ] [ 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 2 H{ { 2 0 } { 3 1 } } }
-} 4 test-bb
-test-diamond
-
-[ ] [ test-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 ] [ 0 1 get live-out? ] unit-test
-[ t ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 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
-
-[ 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 ] [ 0 3 get live-in? ] unit-test
-[ t ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 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 ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ f ] [ 2 4 get live-in? ] 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 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 0 D 0 }
-} 4 test-bb
-V{ } 8 test-bb
-3 { 8 4 } edges
-V{
- T{ ##replace f 1 D 0 }
-} 9 test-bb
-8 9 edge
-V{
- T{ ##replace f 2 D 0 }
-} 5 test-bb
-4 5 edge
-V{ } 10 test-bb
-V{ } 6 test-bb
-5 6 edge
-9 { 6 10 } edges
-V{ } 7 test-bb
-6 { 5 7 } edges
-10 8 edge
-7 2 edge
-
-[ ] [ 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
-[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test
-[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test
-
-[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test
-[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test
-[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test
-[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test
-[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test
-[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test
-[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test
-[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test
-[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test
-
-[ f ] [ 1 get back-edge-target? ] unit-test
-[ t ] [ 2 get back-edge-target? ] unit-test
-[ f ] [ 3 get back-edge-target? ] unit-test
-[ f ] [ 4 get back-edge-target? ] unit-test
-[ t ] [ 5 get back-edge-target? ] unit-test
-[ f ] [ 6 get back-edge-target? ] unit-test
-[ f ] [ 7 get back-edge-target? ] unit-test
-[ t ] [ 8 get back-edge-target? ] unit-test
-[ f ] [ 9 get back-edge-target? ] unit-test
-[ f ] [ 10 get back-edge-target? ] unit-test
-[ f ] [ 11 get back-edge-target? ] 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 ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 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 ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 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
-
-[ 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 ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 5 get live-in? ] unit-test
-[ f ] [ 1 5 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 6 get live-in? ] unit-test
-[ f ] [ 1 6 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 7 get live-in? ] unit-test
-[ f ] [ 1 7 get live-in? ] unit-test
-[ f ] [ 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 ] [ 0 8 get live-in? ] unit-test
-[ t ] [ 1 8 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 9 get live-in? ] unit-test
-[ t ] [ 1 9 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 10 get live-in? ] unit-test
-[ t ] [ 1 10 get live-in? ] unit-test
-[ t ] [ 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 ] [ 0 11 get live-in? ] unit-test
-[ f ] [ 1 11 get live-in? ] unit-test
-[ f ] [ 2 11 get live-in? ] 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
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs accessors
-namespaces fry math sets combinators locals
-compiler.cfg.rpo
-compiler.cfg.dominance
-compiler.cfg.def-use
-compiler.cfg.instructions ;
-FROM: namespaces => set ;
-IN: compiler.cfg.ssa.liveness
-
-! Liveness checking on SSA IR, as described in
-! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
-! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
-
-<PRIVATE
-
-! The sets T_q and R_q are described there
-SYMBOL: T_q-sets
-SYMBOL: R_q-sets
-
-! Targets of back edges
-SYMBOL: back-edge-targets
-
-: T_q ( q -- T_q )
- T_q-sets get at ;
-
-: R_q ( q -- R_q )
- R_q-sets get at ;
-
-: back-edge-target? ( block -- ? )
- back-edge-targets get key? ;
-
-: next-R_q ( q -- R_q )
- [ ] [ successors>> ] [ number>> ] tri
- '[ number>> _ >= ] filter
- [ R_q ] map assoc-combine
- [ conjoin ] keep ;
-
-: set-R_q ( q -- )
- [ next-R_q ] keep R_q-sets get set-at ;
-
-: set-back-edges ( q -- )
- [ successors>> ] [ number>> ] bi '[
- dup number>> _ <
- [ back-edge-targets get conjoin ] [ drop ] if
- ] each ;
-
-: init-R_q ( -- )
- H{ } clone R_q-sets set
- H{ } clone back-edge-targets set ;
-
-: compute-R_q ( cfg -- )
- init-R_q
- post-order [
- [ set-R_q ] [ set-back-edges ] bi
- ] each ;
-
-! This algorithm for computing T_q uses equation (1)
-! but not the faster algorithm described in the paper
-
-: back-edges-from ( q -- edges )
- R_q keys [
- [ successors>> ] [ number>> ] bi
- '[ number>> _ < ] filter
- ] gather ;
-
-: T^_q ( q -- T^_q )
- [ back-edges-from ] [ R_q ] bi
- '[ _ key? not ] filter ;
-
-: next-T_q ( q -- T_q )
- dup dup T^_q [ next-T_q keys ] map
- concat unique [ conjoin ] keep
- [ swap T_q-sets get set-at ] keep ;
-
-: compute-T_q ( cfg -- )
- H{ } T_q-sets set
- [ next-T_q drop ] each-basic-block ;
-
-PRIVATE>
-
-: precompute-liveness ( cfg -- )
- [ compute-R_q ] [ compute-T_q ] bi ;
-
-<PRIVATE
-
-! This doesn't take advantage of ordering T_q,a so you
-! only have to check one if the CFG is reducible.
-! It should be changed to be more efficient.
-
-: only? ( seq obj -- ? )
- '[ _ eq? ] all? ;
-
-: strictly-dominates? ( bb1 bb2 -- ? )
- [ dominates? ] [ eq? not ] 2bi and ;
-
-: T_q,a ( a q -- T_q,a )
- ! This could take advantage of the structure of dominance,
- ! but probably I'll replace it with the algorithm that works
- ! on reducible CFGs anyway
- T_q keys swap def-of
- [ '[ _ swap strictly-dominates? ] filter ] when* ;
-
-: live? ( vreg node quot -- ? )
- [ [ T_q,a ] [ drop uses-of ] 2bi ] dip
- '[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
-
-PRIVATE>
-
-: live-in? ( vreg node -- ? )
- [ drop ] live? ;
-
-<PRIVATE
-
-: (live-out?) ( vreg node -- ? )
- dup dup dup '[
- _ = _ back-edge-target? not and
- [ _ swap remove ] when
- ] live? ;
-
-PRIVATE>
-
-:: live-out? ( vreg node -- ? )
- vreg def-of :> def
- {
- { [ node def eq? ] [ vreg uses-of def only? not ] }
- { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
- [ f ]
- } cond ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order namespaces accessors kernel layouts combinators
-combinators.smart assocs sequences cpu.architecture ;
+USING: math math.order namespaces accessors kernel layouts
+combinators combinators.smart assocs sequences cpu.architecture
+words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame
TUPLE: stack-frame
{ params integer }
{ return integer }
-{ total-size integer }
-{ gc-root-size integer }
{ spill-area-size integer }
+{ total-size integer }
{ calls-vm? boolean } ;
! Stack frame utilities
: spill-offset ( n -- offset )
param-base + ;
-: gc-root-base ( -- n )
- stack-frame get spill-area-size>> param-base + ;
-
-: gc-root-offset ( n -- n' ) gc-root-base + ;
-
: (stack-frame-size) ( stack-frame -- n )
[
- {
- [ params>> ]
- [ return>> ]
- [ gc-root-size>> ]
- [ spill-area-size>> ]
- } cleave
+ [ params>> ] [ return>> ] [ spill-area-size>> ] tri
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
- [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
+ [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
- } 2cleave ;
\ No newline at end of file
+ } 2cleave ;
+
+! PowerPC backend sets frame-required? for ##integer>float too
+\ ##spill t "frame-required?" set-word-prop
+\ ##unary-float-function t "frame-required?" set-word-prop
+\ ##binary-float-function t "frame-required?" set-word-prop
\ No newline at end of file
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
- 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
- [ 2drop ] [ insert-simple-basic-block ] if-empty
+ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
+ [ 2drop ] [ insert-basic-block ] if-empty
] if ;
: visit-block ( bb -- )
: 3inputs ( -- vreg1 vreg2 vreg3 )
(3inputs) -3 inc-d ;
+: binary-op ( quot -- )
+ [ 2inputs ] dip call ds-push ; inline
+
+: unary-op ( quot -- )
+ [ ds-pop ] dip call ds-push ; inline
+
! adjust-d/adjust-r: these are called when other instructions which
! internally adjust the stack height are emitted, such as ##call and
! ##alien-invoke
: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
-
ERROR: uninitialized-peek insn ;
-M: ##peek visit-insn
+: visit-peek ( ##peek -- )
dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
- [ uninitialized-peek ] [ drop ] if ;
+ [ uninitialized-peek ] [ drop ] if ; inline
-M: ##replace visit-insn
+M: ##peek visit-insn visit-peek ;
+
+: visit-replace ( ##replace -- )
loc>> [ n>> ] [ class get ] bi
2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
+M: ##replace visit-insn visit-replace ;
+M: ##replace-imm visit-insn visit-replace ;
+
M: insn visit-insn drop ;
: prepare ( pair -- )
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences math combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+USING: kernel accessors sequences math combinators
+combinators.short-circuit vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
IN: compiler.cfg.useless-conditionals
: delete-conditional? ( bb -- ? )
{
[
- instructions>> last class {
- ##compare-branch
- ##compare-imm-branch
- ##compare-float-ordered-branch
- ##compare-float-unordered-branch
- } member-eq?
+ instructions>> last {
+ [ ##compare-branch? ]
+ [ ##compare-imm-branch? ]
+ [ ##compare-integer-branch? ]
+ [ ##compare-integer-imm-branch? ]
+ [ ##compare-float-ordered-branch? ]
+ [ ##compare-float-unordered-branch? ]
+ } 1||
]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( froms to bb -- )
- bb froms V{ } like >>predecessors drop
- bb to 1vector >>successors drop
- to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
- froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
+:: update-predecessors ( from to bb -- )
+ ! Update 'to' predecessors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
+
+:: update-successors ( from to bb -- )
+ ! Update 'from' successors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
+
+:: insert-basic-block ( from to insns -- )
+ ! Insert basic block on the edge between 'from' and 'to'.
+ <basic-block> :> bb
+ insns V{ } like bb (>>instructions)
+ V{ from } bb (>>predecessors)
+ V{ to } bb (>>successors)
+ from to bb update-predecessors
+ from to bb update-successors ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
,
] with-variable ; inline
-: <simple-block> ( insns -- bb )
- <basic-block>
- swap >vector
- \ ##branch new-insn over push
- >>instructions ;
-
-: insert-simple-basic-block ( from to insns -- )
- [ 1vector ] 2dip <simple-block> insert-basic-block ;
-
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
: predecessor ( bb -- pred )
predecessors>> first ; inline
+: <copy> ( dst src -- insn )
+ any-rep \ ##copy new-insn ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit fry
+kernel make math sequences
+cpu.architecture
+compiler.cfg.hats
+compiler.cfg.utilities
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.alien
+
+M: ##box-displaced-alien rewrite
+ dup displacement>> vreg>insn zero-insn?
+ [ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
+
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 4 1 <class>
+! =>
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 5 3 <class>
+! ##add 4 5 2
+
+: rewrite-unbox-alien ( insn box-insn -- insn )
+ [ dst>> ] [ src>> ] bi* <copy> ;
+
+: rewrite-unbox-displaced-alien ( insn box-insn -- insns )
+ [
+ [ dst>> ]
+ [ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi*
+ [ ^^unbox-c-ptr ] dip
+ ##add
+ ] { } make ;
+
+: rewrite-unbox-any-c-ptr ( insn -- insn/f )
+ dup src>> vreg>insn
+ {
+ { [ dup ##box-alien? ] [ rewrite-unbox-alien ] }
+ { [ dup ##box-displaced-alien? ] [ rewrite-unbox-displaced-alien ] }
+ [ 2drop f ]
+ } cond ;
+
+M: ##unbox-any-c-ptr rewrite rewrite-unbox-any-c-ptr ;
+
+M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
+
+! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
+! just update the offset in the instruction
+: fuse-base-offset? ( insn -- ? )
+ base>> vreg>insn ##add-imm? ;
+
+: fuse-base-offset ( insn -- insn' )
+ dup base>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>base ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add-imm into ##load-memory and ##store-memory
+! just update the offset in the instruction
+: fuse-displacement-offset? ( insn -- ? )
+ { [ scale>> 0 = ] [ displacement>> vreg>insn ##add-imm? ] } 1&& ;
+
+: fuse-displacement-offset ( insn -- insn' )
+ dup displacement>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add into ##load-memory-imm and ##store-memory-imm
+! construct a new ##load-memory or ##store-memory with the
+! ##add's operand as the displacement
+: fuse-displacement? ( insn -- ? )
+ {
+ [ offset>> 0 = complex-addressing? or ]
+ [ base>> vreg>insn ##add? ]
+ } 1&& ;
+
+GENERIC: alien-insn-value ( insn -- value )
+
+M: ##load-memory-imm alien-insn-value dst>> ;
+M: ##store-memory-imm alien-insn-value src>> ;
+
+GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn )
+
+M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ;
+M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
+
+: fuse-displacement ( insn -- insn' )
+ {
+ [ alien-insn-value ]
+ [ base>> vreg>insn [ src1>> ] [ src2>> ] bi ]
+ [ drop 0 ]
+ [ offset>> ]
+ [ rep>> ]
+ [ c-type>> ]
+ [ ]
+ } cleave new-alien-insn ;
+
+! Fuse ##shl-imm into ##load-memory or ##store-memory
+: scale-insn? ( insn -- ? )
+ { [ ##shl-imm? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
+
+: fuse-scale? ( insn -- ? )
+ { [ scale>> 0 = ] [ displacement>> vreg>insn scale-insn? ] } 1&& ;
+
+: fuse-scale ( insn -- insn' )
+ dup displacement>> vreg>insn
+ [ src1>> ] [ src2>> ] bi
+ [ >>displacement ] [ >>scale ] bi* ;
+
+: rewrite-memory-op ( insn -- insn/f )
+ complex-addressing? [
+ {
+ { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+ { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
+ { [ dup fuse-scale? ] [ fuse-scale ] }
+ [ drop f ]
+ } cond
+ ] [ drop f ] if ;
+
+: rewrite-memory-imm-op ( insn -- insn/f )
+ {
+ { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+ { [ dup fuse-displacement? ] [ fuse-displacement ] }
+ [ drop f ]
+ } cond ;
+
+M: ##load-memory rewrite rewrite-memory-op ;
+M: ##load-memory-imm rewrite rewrite-memory-imm-op ;
+M: ##store-memory rewrite rewrite-memory-op ;
+M: ##store-memory-imm rewrite rewrite-memory-imm-op ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel math math.order namespaces
+sequences vectors combinators.short-circuit compiler.cfg
+compiler.cfg.comparisons compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.comparisons
+
+! Optimizations performed here:
+!
+! 1) Eliminating intermediate boolean values when the result of
+! a comparison is used by a compare-branch
+! 2) Folding comparisons where both inputs are literal
+! 3) Folding comparisons where both inputs are congruent
+! 4) Converting compare instructions into compare-imm instructions
+
+: fold-compare-imm? ( insn -- ? )
+ src1>> vreg>insn literal-insn? ;
+
+: evaluate-compare-imm ( insn -- ? )
+ [ src1>> vreg>literal ] [ src2>> ] [ cc>> ] tri
+ {
+ { cc= [ eq? ] }
+ { cc/= [ eq? not ] }
+ } case ;
+
+: fold-compare-integer-imm? ( insn -- ? )
+ src1>> vreg>insn ##load-integer? ;
+
+: evaluate-compare-integer-imm ( insn -- ? )
+ [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
+ [ <=> ] dip evaluate-cc ;
+
+: >compare< ( insn -- in1 in2 cc )
+ [ src1>> ] [ src2>> ] [ cc>> ] tri ; inline
+
+: >test-vector< ( insn -- src1 temp rep vcc )
+ {
+ [ src1>> ]
+ [ drop next-vreg ]
+ [ rep>> ]
+ [ vcc>> ]
+ } cleave ; inline
+
+UNION: scalar-compare-insn
+ ##compare
+ ##compare-imm
+ ##compare-integer
+ ##compare-integer-imm
+ ##compare-float-unordered
+ ##compare-float-ordered ;
+
+UNION: general-compare-insn scalar-compare-insn ##test-vector ;
+
+: rewrite-boolean-comparison? ( insn -- ? )
+ {
+ [ src1>> vreg>insn general-compare-insn? ]
+ [ src2>> not ]
+ [ cc>> cc/= eq? ]
+ } 1&& ; inline
+
+: rewrite-boolean-comparison ( insn -- insn )
+ src1>> vreg>insn {
+ { [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] }
+ { [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] }
+ { [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] }
+ { [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] }
+ { [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] }
+ { [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] }
+ { [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] }
+ } cond ;
+
+: fold-branch ( ? -- insn )
+ 0 1 ?
+ basic-block get [ nth 1vector ] change-successors drop
+ \ ##branch new-insn ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+ evaluate-compare-imm fold-branch ;
+
+M: ##compare-imm-branch rewrite
+ {
+ { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+ [ drop f ]
+ } cond ;
+
+: fold-compare-integer-imm-branch ( insn -- insn/f )
+ evaluate-compare-integer-imm fold-branch ;
+
+M: ##compare-integer-imm-branch rewrite
+ {
+ { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
+ [ drop f ]
+ } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+ [ [ swap ] dip swap-cc ] when ; inline
+
+: (>compare-imm-branch) ( insn swap? -- src1 src2 cc )
+ [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+ (>compare-imm-branch)
+ [ vreg>literal ] dip
+ \ ##compare-imm-branch new-insn ; inline
+
+: >compare-integer-imm-branch ( insn swap? -- insn' )
+ (>compare-imm-branch)
+ [ vreg>integer ] dip
+ \ ##compare-integer-imm-branch new-insn ; inline
+
+: evaluate-self-compare ( insn -- ? )
+ cc>> { cc= cc<= cc>= } member-eq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+ evaluate-self-compare fold-branch ;
+
+M: ##compare-branch rewrite
+ {
+ { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
+ { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
+ { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
+ [ drop f ]
+ } cond ;
+
+M: ##compare-integer-branch rewrite
+ {
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
+ { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
+ [ drop f ]
+ } cond ;
+
+: (>compare-imm) ( insn swap? -- dst src1 src2 cc )
+ [ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip
+ swap-compare ; inline
+
+: >compare-imm ( insn swap? -- insn' )
+ (>compare-imm)
+ [ vreg>literal ] dip
+ next-vreg \ ##compare-imm new-insn ; inline
+
+: >compare-integer-imm ( insn swap? -- insn' )
+ (>compare-imm)
+ [ vreg>integer ] dip
+ next-vreg \ ##compare-integer-imm new-insn ; inline
+
+: >boolean-insn ( insn ? -- insn' )
+ [ dst>> ] dip \ ##load-reference new-insn ;
+
+: rewrite-self-compare ( insn -- insn' )
+ dup evaluate-self-compare >boolean-insn ;
+
+M: ##compare rewrite
+ {
+ { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
+ { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
+ { [ dup diagonal? ] [ rewrite-self-compare ] }
+ [ drop f ]
+ } cond ;
+
+M: ##compare-integer rewrite
+ {
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
+ { [ dup diagonal? ] [ rewrite-self-compare ] }
+ [ drop f ]
+ } cond ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+ {
+ [ src1>> vreg>insn scalar-compare-insn? ]
+ [ src2>> not ]
+ [ cc>> { cc= cc/= } member? ]
+ } 1&& ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+ [ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri {
+ { [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] }
+ { [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] }
+ { [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] }
+ { [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] }
+ { [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] }
+ { [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] }
+ } cond
+ swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+: fold-compare-imm ( insn -- insn' )
+ dup evaluate-compare-imm >boolean-insn ;
+
+M: ##compare-imm rewrite
+ {
+ { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
+ [ drop f ]
+ } cond ;
+
+: fold-compare-integer-imm ( insn -- insn' )
+ dup evaluate-compare-integer-imm >boolean-insn ;
+
+M: ##compare-integer-imm rewrite
+ {
+ { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
+ [ drop f ]
+ } cond ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra classes.parser
-classes.tuple combinators combinators.short-circuit fry
+USING: accessors arrays classes classes.algebra combinators fry
generic.parser kernel math namespaces quotations sequences slots
-splitting words compiler.cfg.instructions
+words make
+compiler.cfg.instructions
compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
+FROM: sequences.private => set-array-nth ;
IN: compiler.cfg.value-numbering.expressions
-TUPLE: constant-expr < expr value ;
-
-C: <constant> constant-expr
-
-M: constant-expr equal?
- over constant-expr? [
- [ value>> ] bi@
- 2dup [ float? ] both? [ fp-bitwise= ] [
- { [ [ class ] bi@ = ] [ = ] } 2&&
- ] if
- ] [ 2drop f ] if ;
-
-TUPLE: reference-expr < expr value ;
-
-C: <reference> reference-expr
-
-M: reference-expr equal?
- over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
-
-M: reference-expr hashcode*
- nip value>> identity-hashcode ;
-
-: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
+<<
GENERIC: >expr ( insn -- expr )
-M: insn >expr drop next-input-expr ;
-
-M: ##load-immediate >expr val>> <constant> ;
+: input-values ( slot-specs -- slot-specs' )
+ [ type>> { use literal } member-eq? ] filter ;
+
+: slot->expr-quot ( slot-spec -- quot )
+ [ name>> reader-word 1quotation ]
+ [
+ type>> {
+ { use [ [ vreg>vn ] ] }
+ { literal [ [ ] ] }
+ } case
+ ] bi append ;
+
+: narray-quot ( length -- quot )
+ [
+ [ , [ f <array> ] % ]
+ [
+ dup iota [
+ - 1 - , [ swap [ set-array-nth ] keep ] %
+ ] with each
+ ] bi
+ ] [ ] make ;
+
+: >expr-quot ( insn slot-specs -- quot )
+ [
+ [ literalize , \ swap , ]
+ [
+ [ [ slot->expr-quot ] map cleave>quot % ]
+ [ length 1 + narray-quot % ]
+ bi
+ ] bi*
+ ] [ ] make ;
+
+: define->expr-method ( insn slot-specs -- )
+ [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
+
+insn-classes get
+[ pure-insn class<= ] filter
+[
+ dup "insn-slots" word-prop input-values
+ define->expr-method
+] each
-M: ##load-reference >expr obj>> <reference> ;
+>>
-M: ##load-constant >expr obj>> <constant> ;
+TUPLE: integer-expr value ;
-<<
+C: <integer-expr> integer-expr
-: input-values ( slot-specs -- slot-specs' )
- [ type>> { use literal constant } member-eq? ] filter ;
+TUPLE: reference-expr value ;
-: expr-class ( insn -- expr )
- name>> "##" ?head drop "-expr" append create-class-in ;
+C: <reference-expr> reference-expr
-: define-expr-class ( insn expr slot-specs -- )
- [ nip expr ] dip [ name>> ] map define-tuple-class ;
+M: reference-expr equal?
+ over reference-expr? [
+ [ value>> ] bi@
+ 2dup [ float? ] both?
+ [ fp-bitwise= ] [ eq? ] if
+ ] [ 2drop f ] if ;
-: >expr-quot ( expr slot-specs -- quot )
- [
- [ name>> reader-word 1quotation ]
- [
- type>> {
- { use [ [ vreg>vn ] ] }
- { literal [ [ ] ] }
- { constant [ [ constant>vn ] ] }
- } case
- ] bi append
- ] map cleave>quot swap suffix \ boa suffix ;
+M: reference-expr hashcode*
+ nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
-: define->expr-method ( insn expr slot-specs -- )
- [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
+M: insn >expr drop input-expr-counter counter neg ;
-: handle-pure-insn ( insn -- )
- [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
- [ define-expr-class ] [ define->expr-method ] 3bi ;
+M: ##copy >expr "Fail" throw ;
-insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
+M: ##load-integer >expr val>> <integer-expr> ;
->>
+M: ##load-reference >expr obj>> <reference-expr> ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel layouts math math.bitwise
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.folding
+
+: binary-constant-fold? ( insn -- ? )
+ src1>> vreg>insn ##load-integer? ; inline
+
+GENERIC: binary-constant-fold* ( x y insn -- z )
+
+M: ##add-imm binary-constant-fold* drop + ;
+M: ##sub-imm binary-constant-fold* drop - ;
+M: ##mul-imm binary-constant-fold* drop * ;
+M: ##and-imm binary-constant-fold* drop bitand ;
+M: ##or-imm binary-constant-fold* drop bitor ;
+M: ##xor-imm binary-constant-fold* drop bitxor ;
+M: ##shr-imm binary-constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
+M: ##sar-imm binary-constant-fold* drop neg shift ;
+M: ##shl-imm binary-constant-fold* drop shift ;
+
+: binary-constant-fold ( insn -- insn' )
+ [ dst>> ]
+ [ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi
+ \ ##load-integer new-insn ; inline
+
+: unary-constant-fold? ( insn -- ? )
+ src>> vreg>insn ##load-integer? ; inline
+
+GENERIC: unary-constant-fold* ( x insn -- y )
+
+M: ##not unary-constant-fold* drop bitnot ;
+M: ##neg unary-constant-fold* drop neg ;
+
+: unary-constant-fold ( insn -- insn' )
+ [ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi
+ \ ##load-integer new-insn ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces assocs biassocs ;
+USING: accessors kernel math namespaces assocs ;
IN: compiler.cfg.value-numbering.graph
-SYMBOL: vn-counter
-
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-TUPLE: expr ;
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-! Expressions whose values are inputs to the basic block.
-TUPLE: input-expr < expr n ;
-
SYMBOL: input-expr-counter
-: next-input-expr ( -- expr )
- input-expr-counter counter input-expr boa ;
-
+! assoc mapping vregs to value numbers
+! this is the identity on canonical representatives
SYMBOL: vregs>vns
-: vreg>vn ( vreg -- vn )
- vregs>vns get [ drop next-input-expr expr>vn ] cache ;
+! assoc mapping expressions to value numbers
+SYMBOL: exprs>vns
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+! assoc mapping value numbers to instructions
+SYMBOL: vns>insns
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+: vn>insn ( vn -- insn ) vns>insns get at ;
-: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+: vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ;
-: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ;
: init-value-graph ( -- )
- 0 vn-counter set
0 input-expr-counter set
- <bihash> exprs>vns set
- <bihash> vregs>vns set ;
+ H{ } clone vregs>vns set
+ H{ } clone exprs>vns set
+ H{ } clone vns>insns set ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit
+cpu.architecture fry kernel layouts locals make math sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.value-numbering.folding
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.math
+
+: f-insn? ( insn -- ? )
+ { [ ##load-reference? ] [ obj>> not ] } 1&& ; inline
+
+: zero-insn? ( insn -- ? )
+ { [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline
+
+M: ##tagged>integer rewrite
+ [ dst>> ] [ src>> vreg>insn ] bi {
+ { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] }
+ { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] }
+ [ 2drop f ]
+ } cond ;
+
+: self-inverse ( insn -- insn' )
+ [ dst>> ] [ src>> vreg>insn src>> ] bi <copy> ;
+
+: identity ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi <copy> ;
+
+M: ##neg rewrite
+ {
+ { [ dup src>> vreg>insn ##neg? ] [ self-inverse ] }
+ { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+M: ##not rewrite
+ {
+ { [ dup src>> vreg>insn ##not? ] [ self-inverse ] }
+ { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+! Reassociation converts
+! ## *-imm 2 1 X
+! ## *-imm 3 2 Y
+! into
+! ## *-imm 3 1 (X $ Y)
+! If * is associative, then $ is the same operation as *.
+! In the case of shifts, $ is addition.
+: (reassociate) ( insn -- dst src1 src2' src2'' )
+ {
+ [ dst>> ]
+ [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ]
+ [ src2>> ]
+ } cleave ; inline
+
+: reassociate ( insn -- dst src1 src2 )
+ [ (reassociate) ] keep binary-constant-fold* ;
+
+: ?new-insn ( dst src1 src2 ? class -- insn/f )
+ '[ _ new-insn ] [ 3drop f ] if ; inline
+
+: reassociate-arithmetic ( insn new-insn -- insn/f )
+ [ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline
+
+: reassociate-bitwise ( insn new-insn -- insn/f )
+ [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
+
+: reassociate-shift ( insn new-insn -- insn/f )
+ [ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline
+
+M: ##add-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] }
+ [ drop f ]
+ } cond ;
+
+: sub-imm>add-imm ( insn -- insn' )
+ [ dst>> ] [ src1>> ] [ src2>> neg ] tri
+ dup immediate-arithmetic?
+ \ ##add-imm ?new-insn ;
+
+M: ##sub-imm rewrite sub-imm>add-imm ;
+
+! Convert ##mul-imm -1 => ##neg
+: mul-to-neg? ( insn -- ? )
+ src2>> -1 = ;
+
+: mul-to-neg ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
+
+! Convert ##mul-imm 2^X => ##shl-imm X
+: mul-to-shl? ( insn -- ? )
+ src2>> power-of-2? ;
+
+: mul-to-shl ( insn -- insn' )
+ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
+! Distribution converts
+! ##+-imm 2 1 X
+! ##*-imm 3 2 Y
+! Into
+! ##*-imm 4 1 Y
+! ##+-imm 3 4 X*Y
+! Where * is mul or shl, + is add or sub
+! Have to make sure that X*Y fits in an immediate
+:: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f )
+ imm immediate-arithmetic? [
+ [
+ temp inner src1>> outer src2>> mul-op execute
+ outer dst>> temp imm add-op execute
+ ] { } make
+ ] [ f ] if ; inline
+
+: distribute-over-add? ( insn -- ? )
+ src1>> vreg>insn ##add-imm? ;
+
+: distribute-over-sub? ( insn -- ? )
+ src1>> vreg>insn ##sub-imm? ;
+
+: distribute ( insn add-op mul-op -- new-insns/f )
+ [
+ dup src1>> vreg>insn
+ 2dup src2>> swap [ src2>> ] keep binary-constant-fold*
+ next-vreg
+ ] 2dip (distribute) ; inline
+
+M: ##mul-imm rewrite
+ {
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup mul-to-neg? ] [ mul-to-neg ] }
+ { [ dup mul-to-shl? ] [ mul-to-shl ] }
+ { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
+ { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
+ { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
+ [ drop f ]
+ } cond ;
+
+M: ##and-imm rewrite
+ {
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] }
+ { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
+ { [ dup src2>> -1 = ] [ identity ] }
+ [ drop f ]
+ } cond ;
+
+M: ##or-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] }
+ [ drop f ]
+ } cond ;
+
+M: ##xor-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shl-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
+ { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
+ { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shr-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] }
+ [ drop f ]
+ } cond ;
+
+M: ##sar-imm rewrite
+ {
+ { [ dup src2>> 0 = ] [ identity ] }
+ { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+ { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] }
+ [ drop f ]
+ } cond ;
+
+! Convert
+! ##load-integer 2 X
+! ##* 3 1 2
+! Where * is an operation with an -imm equivalent into
+! ##*-imm 3 1 X
+: insn>imm-insn ( insn op swap? -- new-insn )
+ swap [
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
+ [ swap ] when vreg>integer
+ ] dip new-insn ; inline
+
+M: ##add rewrite
+ {
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+: diagonal? ( insn -- ? )
+ [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline
+
+! ##sub 2 1 1 => ##load-integer 2 0
+: rewrite-subtraction-identity ( insn -- insn' )
+ dst>> 0 \ ##load-integer new-insn ;
+
+! ##load-integer 1 0
+! ##sub 3 1 2
+! =>
+! ##neg 3 2
+: sub-to-neg? ( ##sub -- ? )
+ src1>> vreg>insn zero-insn? ;
+
+: sub-to-neg ( ##sub -- insn )
+ [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
+M: ##sub rewrite
+ {
+ { [ dup sub-to-neg? ] [ sub-to-neg ] }
+ { [ dup diagonal? ] [ rewrite-subtraction-identity ] }
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##mul rewrite
+ {
+ { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##and rewrite
+ {
+ { [ dup diagonal? ] [ identity ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##or rewrite
+ {
+ { [ dup diagonal? ] [ identity ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##xor rewrite
+ {
+ { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] }
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
+ { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shl rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shr rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
+
+M: ##sar rewrite
+ {
+ { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] }
+ [ drop f ]
+ } cond ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors cpu.architecture kernel
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.misc
+
+M: ##replace rewrite
+ [ loc>> ] [ src>> vreg>insn ] bi
+ dup literal-insn? [
+ insn>literal dup immediate-store?
+ [ swap \ ##replace-imm new-insn ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
+! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit arrays
-fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes
-vectors locals make alien.c-types io.binary grouping
-compiler.cfg
-compiler.cfg.registers
-compiler.cfg.comparisons
+USING: accessors combinators combinators.short-circuit kernel
+layouts math cpu.architecture
compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.rewrite
-: vreg-immediate-arithmetic? ( vreg -- ? )
- vreg>expr {
- [ constant-expr? ]
- [ value>> fixnum? ]
- [ value>> immediate-arithmetic? ]
- } 1&& ;
-
-: vreg-immediate-bitwise? ( vreg -- ? )
- vreg>expr {
- [ constant-expr? ]
- [ value>> fixnum? ]
- [ value>> immediate-bitwise? ]
- } 1&& ;
-
-: vreg-immediate-comparand? ( vreg -- ? )
- vreg>expr {
- [ constant-expr? ]
- [ value>> immediate-comparand? ]
- } 1&& ;
-
! Outputs f to mean no change
-
GENERIC: rewrite ( insn -- insn/f )
M: insn rewrite drop f ;
-: ##branch-t? ( insn -- ? )
- dup ##compare-imm-branch? [
- { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
- ] [ drop f ] if ; inline
-
-: general-compare-expr? ( insn -- ? )
- {
- [ compare-expr? ]
- [ compare-imm-expr? ]
- [ compare-float-unordered-expr? ]
- [ compare-float-ordered-expr? ]
- } 1|| ;
-
-: general-or-vector-compare-expr? ( insn -- ? )
- {
- [ compare-expr? ]
- [ compare-imm-expr? ]
- [ compare-float-unordered-expr? ]
- [ compare-float-ordered-expr? ]
- [ test-vector-expr? ]
- } 1|| ;
-
-: rewrite-boolean-comparison? ( insn -- ? )
- dup ##branch-t? [
- src1>> vreg>expr general-or-vector-compare-expr?
- ] [ drop f ] if ; inline
-
-: >compare-expr< ( expr -- in1 in2 cc )
- [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-imm-expr< ( expr -- in1 in2 cc )
- [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
- {
- [ src1>> vn>vreg ]
- [ drop next-vreg ]
- [ rep>> ]
- [ vcc>> ]
- } cleave ; inline
-
-: rewrite-boolean-comparison ( expr -- insn )
- src1>> vreg>expr {
- { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
- { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
- { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
- { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
- { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
- } cond ;
-
-: tag-fixnum-expr? ( expr -- ? )
- dup shl-imm-expr?
- [ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
-
-: rewrite-tagged-comparison? ( insn -- ? )
- #! Are we comparing two tagged fixnums? Then untag them.
- {
- [ src1>> vreg>expr tag-fixnum-expr? ]
- [ src2>> tag-mask get bitand 0 = ]
- } 1&& ; inline
-
-: tagged>constant ( n -- n' )
- tag-bits get neg shift ; inline
-
-: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
- [ src1>> vreg>expr src1>> vn>vreg ]
- [ src2>> tagged>constant ]
- [ cc>> ]
- tri ; inline
-
-GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
-
-M: ##compare-imm-branch rewrite-tagged-comparison
- (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
-
-M: ##compare-imm rewrite-tagged-comparison
- [ dst>> ] [ (rewrite-tagged-comparison) ] bi
- next-vreg \ ##compare-imm new-insn ;
-
-: rewrite-redundant-comparison? ( insn -- ? )
- {
- [ src1>> vreg>expr general-compare-expr? ]
- [ src2>> not ]
- [ cc>> { cc= cc/= } member? ]
- } 1&& ; inline
-
-: rewrite-redundant-comparison ( insn -- insn' )
- [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
- { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
- { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
- { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
- { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
- } cond
- swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-
-: (fold-compare-imm) ( insn -- ? )
- [ src1>> vreg>constant ] [ src2>> ] [ cc>> ] tri
- 2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
- {
- { cc= [ eq? ] }
- { cc/= [ eq? not ] }
- } case
- ] if ;
-
-: fold-compare-imm? ( insn -- ? )
- src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
-
-: fold-branch ( ? -- insn )
- 0 1 ?
- basic-block get [ nth 1vector ] change-successors drop
- \ ##branch new-insn ;
-
-: fold-compare-imm-branch ( insn -- insn/f )
- (fold-compare-imm) fold-branch ;
-
-M: ##compare-imm-branch rewrite
- {
- { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
- { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
- { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
- [ drop f ]
- } cond ;
-
-: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
- [ [ swap ] dip swap-cc ] when ; inline
-
-: >compare-imm-branch ( insn swap? -- insn' )
- [
- [ src1>> ]
- [ src2>> ]
- [ cc>> ]
- tri
- ] dip
- swap-compare
- [ vreg>constant ] dip
- \ ##compare-imm-branch new-insn ; inline
-
-: self-compare? ( insn -- ? )
- [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
-
-: (rewrite-self-compare) ( insn -- ? )
- cc>> { cc= cc<= cc>= } member-eq? ;
-
-: rewrite-self-compare-branch ( insn -- insn' )
- (rewrite-self-compare) fold-branch ;
-
-M: ##compare-branch rewrite
- {
- { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
- { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
- { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
- [ drop f ]
- } cond ;
-
-: >compare-imm ( insn swap? -- insn' )
- [
- {
- [ dst>> ]
- [ src1>> ]
- [ src2>> ]
- [ cc>> ]
- } cleave
- ] dip
- swap-compare
- [ vreg>constant ] dip
- next-vreg \ ##compare-imm new-insn ; inline
-
-: >boolean-insn ( insn ? -- insn' )
- [ dst>> ] dip \ ##load-constant new-insn ;
-
-: rewrite-self-compare ( insn -- insn' )
- dup (rewrite-self-compare) >boolean-insn ;
-
-M: ##compare rewrite
- {
- { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
- { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
- { [ dup self-compare? ] [ rewrite-self-compare ] }
- [ drop f ]
- } cond ;
-
-: fold-compare-imm ( insn -- insn' )
- dup (fold-compare-imm) >boolean-insn ;
-
-M: ##compare-imm rewrite
- {
- { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
- { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
- { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
- [ drop f ]
- } cond ;
-
-: constant-fold? ( insn -- ? )
- src1>> vreg>expr constant-expr? ; inline
-
-GENERIC: constant-fold* ( x y insn -- z )
-
-M: ##add-imm constant-fold* drop + ;
-M: ##sub-imm constant-fold* drop - ;
-M: ##mul-imm constant-fold* drop * ;
-M: ##and-imm constant-fold* drop bitand ;
-M: ##or-imm constant-fold* drop bitor ;
-M: ##xor-imm constant-fold* drop bitxor ;
-M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
-M: ##sar-imm constant-fold* drop neg shift ;
-M: ##shl-imm constant-fold* drop shift ;
-
-: constant-fold ( insn -- insn' )
- [ dst>> ]
- [
- [ src1>> vreg>constant \ f type-number or ]
- [ src2>> ]
- [ ]
- tri constant-fold*
- ] bi
- \ ##load-immediate new-insn ; inline
-
-: unary-constant-fold? ( insn -- ? )
- src>> vreg>expr constant-expr? ; inline
-
-GENERIC: unary-constant-fold* ( x insn -- y )
+! Utilities
+GENERIC: insn>integer ( insn -- n )
-M: ##not unary-constant-fold* drop bitnot ;
-M: ##neg unary-constant-fold* drop neg ;
+M: ##load-integer insn>integer val>> ;
-: unary-constant-fold ( insn -- insn' )
- [ dst>> ]
- [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
- \ ##load-immediate new-insn ; inline
+: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
-: maybe-unary-constant-fold ( insn -- insn' )
- dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
-
-M: ##neg rewrite
- maybe-unary-constant-fold ;
-
-M: ##not rewrite
- maybe-unary-constant-fold ;
-
-: arithmetic-op? ( op -- ? )
- {
- ##add
- ##add-imm
- ##sub
- ##sub-imm
- ##mul
- ##mul-imm
- } member-eq? ;
-
-: immediate? ( value op -- ? )
- arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
-
-: reassociate ( insn op -- insn )
- [
- {
- [ dst>> ]
- [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
- [ src2>> ]
- [ ]
- } cleave constant-fold*
- ] dip
- 2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
-
-M: ##add-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
- [ drop f ]
- } cond ;
-
-: sub-imm>add-imm ( insn -- insn' )
- [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
- [ \ ##add-imm new-insn ] [ 3drop f ] if ;
-
-M: ##sub-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ sub-imm>add-imm ]
- } cond ;
-
-: mul-to-neg? ( insn -- ? )
- src2>> -1 = ;
-
-: mul-to-neg ( insn -- insn' )
- [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
-
-: mul-to-shl? ( insn -- ? )
- src2>> power-of-2? ;
-
-: mul-to-shl ( insn -- insn' )
- [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+: vreg-immediate-arithmetic? ( vreg -- ? )
+ vreg>insn {
+ [ ##load-integer? ]
+ [ val>> immediate-arithmetic? ]
+ } 1&& ;
-M: ##mul-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup mul-to-neg? ] [ mul-to-neg ] }
- { [ dup mul-to-shl? ] [ mul-to-shl ] }
- { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
- [ drop f ]
- } cond ;
+: vreg-immediate-bitwise? ( vreg -- ? )
+ vreg>insn {
+ [ ##load-integer? ]
+ [ val>> immediate-bitwise? ]
+ } 1&& ;
-M: ##and-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
- [ drop f ]
- } cond ;
+UNION: literal-insn ##load-integer ##load-reference ;
-M: ##or-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
- [ drop f ]
- } cond ;
+GENERIC: insn>literal ( insn -- n )
-M: ##xor-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
- [ drop f ]
- } cond ;
+M: ##load-integer insn>literal val>> >fixnum ;
-M: ##shl-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ drop f ]
- } cond ;
+M: ##load-reference insn>literal obj>> ;
-M: ##shr-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
- [ drop f ]
- } cond ;
+: vreg>literal ( vreg -- n ) vreg>insn insn>literal ; inline
-M: ##sar-imm rewrite
- {
- { [ dup constant-fold? ] [ constant-fold ] }
+: vreg-immediate-comparand? ( vreg -- ? )
+ vreg>insn {
+ { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
+ { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
[ drop f ]
} cond ;
-
-: insn>imm-insn ( insn op swap? -- new-insn )
- swap [
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
- [ swap ] when vreg>constant
- ] dip new-insn ; inline
-
-: vreg-immediate? ( vreg op -- ? )
- arithmetic-op?
- [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
-
-: rewrite-arithmetic ( insn op -- insn/f )
- {
- { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
- [ 2drop f ]
- } cond ; inline
-
-: rewrite-arithmetic-commutative ( insn op -- insn/f )
- {
- { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
- { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
- [ 2drop f ]
- } cond ; inline
-
-M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
-
-: subtraction-identity? ( insn -- ? )
- [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
-
-: rewrite-subtraction-identity ( insn -- insn' )
- dst>> 0 \ ##load-immediate new-insn ;
-
-: sub-to-neg? ( ##sub -- ? )
- src1>> vn>expr expr-zero? ;
-
-: sub-to-neg ( ##sub -- insn )
- [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
-
-M: ##sub rewrite
- {
- { [ dup sub-to-neg? ] [ sub-to-neg ] }
- { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
- [ \ ##sub-imm rewrite-arithmetic ]
- } cond ;
-
-M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
-
-M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
-
-M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
-
-M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
-
-M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
-
-M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
-
-M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
-
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 4 1 <class>
-! =>
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 5 3 <class>
-! ##add 4 5 2
-
-:: rewrite-unbox-displaced-alien ( insn expr -- insns )
- [
- next-vreg :> temp
- temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
- insn dst>> temp expr displacement>> vn>vreg ##add
- ] { } make ;
-
-M: ##unbox-any-c-ptr rewrite
- dup src>> vreg>expr dup box-displaced-alien-expr?
- [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-
-! More efficient addressing for alien intrinsics
-: rewrite-alien-addressing ( insn -- insn' )
- dup src>> vreg>expr dup add-imm-expr? [
- [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
- [ >>src ] [ '[ _ + ] change-offset ] bi*
- ] [ 2drop f ] if ;
-
-M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
-M: ##alien-float rewrite rewrite-alien-addressing ;
-M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
-M: ##set-alien-float rewrite rewrite-alien-addressing ;
-M: ##set-alien-double rewrite rewrite-alien-addressing ;
-
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.vectors.simd.intrinsics
compiler.cfg
compiler.cfg.registers
+compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.math
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering.simd
-M: ##alien-vector rewrite rewrite-alien-addressing ;
-M: ##set-alien-vector rewrite rewrite-alien-addressing ;
-
! Some lame constant folding for SIMD intrinsics. Eventually this
! should be redone completely.
-: rewrite-shuffle-vector-imm ( insn expr -- insn' )
+: useless-shuffle-vector-imm? ( insn -- ? )
+ [ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ;
+
+: compose-shuffle-vector-imm ( outer inner -- insn' )
2dup [ rep>> ] bi@ eq? [
- [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+ [ [ dst>> ] [ src>> ] bi* ]
[ [ shuffle>> ] bi@ nths ]
[ drop rep>> ]
2tri \ ##shuffle-vector-imm new-insn
: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
2dup length swap length /i group nths concat ;
-: fold-shuffle-vector-imm ( insn expr -- insn' )
- [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
- (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
+: fold-shuffle-vector-imm ( outer inner -- insn' )
+ [ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi*
+ (fold-shuffle-vector-imm) \ ##load-reference new-insn ;
M: ##shuffle-vector-imm rewrite
- dup src>> vreg>expr {
- { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
- { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
- { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
+ dup src>> vreg>insn {
+ { [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi <copy> ] }
+ { [ dup ##shuffle-vector-imm? ] [ compose-shuffle-vector-imm ] }
+ { [ dup ##load-reference? ] [ fold-shuffle-vector-imm ] }
[ 2drop f ]
} cond ;
: (fold-scalar>vector) ( insn bytes -- insn' )
[ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
- \ ##load-constant new-insn ;
+ \ ##load-reference new-insn ;
-: fold-scalar>vector ( insn expr -- insn' )
- value>> over rep>> {
+: fold-scalar>vector ( outer inner -- insn' )
+ obj>> over rep>> {
{ float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
{ double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
[ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
} case ;
M: ##scalar>vector rewrite
- dup src>> vreg>expr dup constant-expr?
- [ fold-scalar>vector ] [ 2drop f ] if ;
+ dup src>> vreg>insn {
+ { [ dup ##load-reference? ] [ fold-scalar>vector ] }
+ { [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
+ [ 2drop f ]
+ } cond ;
M: ##xor-vector rewrite
- dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+ dup diagonal?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
-: vector-not? ( expr -- ? )
+: vector-not? ( insn -- ? )
{
- [ not-vector-expr? ]
+ [ ##not-vector? ]
[ {
- [ xor-vector-expr? ]
- [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+ [ ##xor-vector? ]
+ [ [ src1>> ] [ src2>> ] bi [ vreg>insn ##fill-vector? ] either? ]
} 1&& ]
} 1|| ;
-GENERIC: vector-not-src ( expr -- vreg )
-M: not-vector-expr vector-not-src src>> vn>vreg ;
-M: xor-vector-expr vector-not-src
- dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+GENERIC: vector-not-src ( insn -- vreg )
+
+M: ##not-vector vector-not-src
+ src>> ;
+
+M: ##xor-vector vector-not-src
+ dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
M: ##and-vector rewrite
{
- { [ dup src1>> vreg>expr vector-not? ] [
+ { [ dup src1>> vreg>insn vector-not? ] [
{
[ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
+ [ src1>> vreg>insn vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
- { [ dup src2>> vreg>expr vector-not? ] [
+ { [ dup src2>> vreg>insn vector-not? ] [
{
[ dst>> ]
- [ src2>> vreg>expr vector-not-src ]
+ [ src2>> vreg>insn vector-not-src ]
[ src1>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
} cond ;
M: ##andn-vector rewrite
- dup src1>> vreg>expr vector-not? [
+ dup src1>> vreg>insn vector-not? [
{
[ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
+ [ src1>> vreg>insn vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##and-vector new-insn
] [ drop f ] if ;
-
-M: scalar>vector-expr simplify*
- src>> vn>expr {
- { [ dup vector>scalar-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-M: shuffle-vector-imm-expr simplify*
- [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
- sequence= [ drop f ] unless ;
-
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math layouts
-sequences
-compiler.cfg.instructions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
-IN: compiler.cfg.value-numbering.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-M: copy-expr simplify* src>> ;
-
-: simplify-unbox-alien ( expr -- vn/expr/f )
- src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
-
-M: unbox-alien-expr simplify* simplify-unbox-alien ;
-
-M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
-
-: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-
-: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
-
-: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
-
-: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
-
-M: neg-expr simplify*
- >unary-expr< {
- { [ dup neg-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-M: not-expr simplify*
- >unary-expr< {
- { [ dup not-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-: >binary-expr< ( expr -- in1 in2 )
- [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
-
-: simplify-add ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: add-expr simplify* simplify-add ;
-M: add-imm-expr simplify* simplify-add ;
-
-: simplify-sub ( expr -- vn/expr/f )
- >binary-expr< {
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: sub-expr simplify* simplify-sub ;
-M: sub-imm-expr simplify* simplify-sub ;
-
-: simplify-mul ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-one? ] [ drop ] }
- { [ dup expr-one? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: mul-expr simplify* simplify-mul ;
-M: mul-imm-expr simplify* simplify-mul ;
-
-: simplify-and ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup eq? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: and-expr simplify* simplify-and ;
-M: and-imm-expr simplify* simplify-and ;
-
-: simplify-or ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup eq? ] [ drop ] }
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: or-expr simplify* simplify-or ;
-M: or-imm-expr simplify* simplify-or ;
-
-: simplify-xor ( expr -- vn/expr/f )
- >binary-expr< {
- { [ over expr-zero? ] [ nip ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: xor-expr simplify* simplify-xor ;
-M: xor-imm-expr simplify* simplify-xor ;
-
-: useless-shr? ( in1 in2 -- ? )
- over shl-imm-expr?
- [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
-
-: simplify-shr ( expr -- vn/expr/f )
- >binary-expr< {
- { [ 2dup useless-shr? ] [ drop src1>> ] }
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: shr-expr simplify* simplify-shr ;
-M: shr-imm-expr simplify* simplify-shr ;
-
-: simplify-shl ( expr -- vn/expr/f )
- >binary-expr< {
- { [ dup expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ; inline
-
-M: shl-expr simplify* simplify-shl ;
-M: shl-imm-expr simplify* simplify-shl ;
-
-M: box-displaced-alien-expr simplify*
- [ base>> ] [ displacement>> ] bi {
- { [ dup vn>expr expr-zero? ] [ drop ] }
- [ 2drop f ]
- } cond ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
- dup simplify* {
- { [ dup not ] [ drop expr>vn ] }
- { [ dup expr? ] [ expr>vn nip ] }
- { [ dup integer? ] [ nip ] }
- } cond ;
-
-: number-values ( insn -- )
- [ >expr simplify ] [ dst>> ] bi set-vn ;
+++ /dev/null
-Algebraic simplification of expressions
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit cpu.architecture fry
+kernel math
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.slots
+
+: simplify-slot-addressing? ( insn -- ? )
+ complex-addressing?
+ [ slot>> vreg>insn ##add-imm? ] [ drop f ] if ;
+
+: simplify-slot-addressing ( insn -- insn/f )
+ dup simplify-slot-addressing? [
+ dup slot>> vreg>insn
+ [ src1>> >>slot ]
+ [ src2>> over scale>> '[ _ _ shift - ] change-tag ]
+ bi
+ ] [ drop f ] if ;
+
+M: ##slot rewrite simplify-slot-addressing ;
+M: ##set-slot rewrite simplify-slot-addressing ;
+M: ##write-barrier rewrite simplify-slot-addressing ;
compiler.cfg.representations compiler.cfg assocs vectors arrays
layouts literals namespaces alien compiler.cfg.value-numbering.simd
system ;
+QUALIFIED-WITH: alien.c-types c
IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )
dup {
[ ##compare? ]
[ ##compare-imm? ]
+ [ ##compare-integer? ]
+ [ ##compare-integer-imm? ]
[ ##compare-float-unordered? ]
[ ##compare-float-ordered? ]
[ ##test-vector? ]
! Folding constants together
[
{
- T{ ##load-constant f 0 0.0 }
- T{ ##load-constant f 1 -0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
}
] [
{
- T{ ##load-constant f 0 0.0 }
- T{ ##load-constant f 1 -0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-constant f 0 0.0 }
+ 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-constant f 0 0.0 }
- T{ ##load-constant f 1 0.0 }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 0.0 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-constant f 0 t }
+ 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-constant f 0 t }
- T{ ##load-constant f 1 t }
- T{ ##replace f 0 D 0 }
- T{ ##replace f 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##load-reference f 1 t }
} value-numbering-step
] unit-test
-! Compare propagation
+! ##load-reference/##replace fusion
+cpu x86? [
+ [
+ {
+ T{ ##load-integer f 0 10 }
+ T{ ##replace-imm f 10 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 10 }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 0 f }
+ T{ ##replace-imm f f D 0 }
+ }
+ ] [
+ {
+ T{ ##load-reference f 0 f }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+cpu x86.32? [
+ [
+ {
+ T{ ##load-reference f 0 + }
+ T{ ##replace-imm f + D 0 }
+ }
+ ] [
+ {
+ T{ ##load-reference f 0 + }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+cpu x86.64? [
+ [
+ {
+ T{ ##load-integer f 0 10,000,000,000 }
+ T{ ##replace f 0 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 10,000,000,000 }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+
+ ! Boundary case
+ [
+ {
+ T{ ##load-integer f 0 HEX: 7fffffff }
+ T{ ##replace f 0 D 0 }
+ }
+ ] [
+ {
+ T{ ##load-integer f 0 HEX: 7fffffff }
+ T{ ##replace f 0 D 0 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+! Double compare elimination
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare f 4 2 1 cc= }
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 6 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare f 4 2 1 cc= }
+ T{ ##compare-imm f 6 4 f cc/= }
+ T{ ##replace f 6 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm f 2 1 16 cc= }
+ T{ ##copy f 3 2 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm f 2 1 16 cc= }
+ T{ ##compare-imm f 3 2 f cc/= }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc> }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc> }
T{ ##copy f 6 4 any-rep }
T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc> }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc> }
T{ ##compare-imm f 6 4 f cc/= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
[
{
- 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{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc<= }
+ T{ ##compare-integer f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f 1 + }
- T{ ##peek f 2 D 0 }
- T{ ##compare f 4 2 1 cc<= }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##compare-integer f 4 2 1 cc<= }
T{ ##compare-imm f 6 4 f cc= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
+[
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm f 2 1 100 cc<= }
+ T{ ##compare-integer-imm f 3 1 100 cc/<= }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-integer-imm f 2 1 100 cc<= }
+ T{ ##compare-imm f 3 2 f cc= }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 8 D 0 }
{
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{ ##compare f 33 29 30 cc= }
+ T{ ##compare-branch f 29 30 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 f cc/= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare-integer f 33 29 30 cc<= }
+ T{ ##compare-integer-branch f 29 30 cc<= }
}
] [
{
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
- T{ ##compare f 33 29 30 cc<= }
+ T{ ##compare-integer f 33 29 30 cc<= }
T{ ##compare-imm-branch f 33 f cc/= }
} value-numbering-step trim-temps
] unit-test
} value-numbering-step trim-temps
] unit-test
-! Immediate operand conversion
+cpu x86.32? [
+ [
+ {
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm f 2 1 + cc= }
+ T{ ##compare-imm-branch f 1 + cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm f 2 1 + cc= }
+ T{ ##compare-imm-branch f 2 f cc/= }
+ } value-numbering-step trim-temps
+ ] unit-test
+] when
+
+! Immediate operand fusion
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 0 -100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##sub f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##neg f 2 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##sub f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##neg f 2 0 }
T{ ##copy f 3 0 any-rep }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 0 }
+ T{ ##load-integer f 1 0 }
T{ ##sub f 2 1 0 }
T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##neg f 1 0 }
+ T{ ##neg f 2 1 }
+ } value-numbering-step
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##and f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##or f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor f 2 0 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor-imm f 2 0 100 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
+ T{ ##load-integer f 1 100 }
T{ ##xor f 2 1 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm f 2 0 100 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc= }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 0 100 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare f 2 0 1 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer f 2 0 1 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 + }
+ T{ ##load-reference f 1 + }
T{ ##compare-imm f 2 0 + cc= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 + }
+ T{ ##load-reference f 1 + }
T{ ##compare f 2 0 1 cc= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 + }
+ T{ ##load-reference f 1 + }
T{ ##compare-imm-branch f 0 + cc= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 + }
+ T{ ##load-reference f 1 + }
T{ ##compare-branch f 0 1 cc= }
} value-numbering-step trim-temps
] unit-test
] when
+cpu x86.32? [
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ } value-numbering-step trim-temps
+ ] unit-test
+] unless
+
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare f 2 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 0 100 cc>= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare f 2 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer f 2 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare-branch f 0 1 cc= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm-branch f 0 100 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 3.5 }
- T{ ##compare-branch f 0 1 cc= }
- } value-numbering-step trim-temps
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-branch f 0 1 cc<= }
+ } value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm f 2 0 100 cc>= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm-branch f 0 100 cc>= }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare f 2 1 0 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-branch f 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
+! Compare folding
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm-branch f 0 100 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-branch f 0 1 cc<= }
- } value-numbering-step
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##compare-integer f 3 1 2 cc<= }
+ } value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm-branch f 0 100 cc>= }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##load-reference f 3 f }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 100 }
- T{ ##compare-branch f 1 0 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 200 }
+ T{ ##compare-integer f 3 1 2 cc= }
} value-numbering-step trim-temps
] unit-test
-! Branch folding
[
{
- T{ ##load-immediate f 1 100 }
- T{ ##load-immediate f 2 200 }
- T{ ##load-constant f 3 t }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-reference f 2 f }
}
] [
{
- T{ ##load-immediate f 1 100 }
- T{ ##load-immediate f 2 200 }
- T{ ##compare f 3 1 2 cc<= }
+ T{ ##load-integer f 1 100 }
+ T{ ##compare-integer-imm f 2 1 123 cc= }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##load-immediate f 1 100 }
- T{ ##load-immediate f 2 200 }
- T{ ##load-constant f 3 f }
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##load-reference f 3 f }
}
] [
{
- T{ ##load-immediate f 1 100 }
- T{ ##load-immediate f 2 200 }
- T{ ##compare f 3 1 2 cc= }
- } value-numbering-step trim-temps
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##compare-integer f 3 1 2 cc= }
+ } value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f 1 100 }
- T{ ##load-constant f 2 f }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-immediate f 1 100 }
- T{ ##compare-imm f 2 1 f cc= }
- } value-numbering-step trim-temps
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer f 3 1 2 cc/= }
+ } value-numbering-step
] unit-test
[
{
- T{ ##load-constant f 1 f }
- T{ ##load-constant f 2 t }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-constant f 1 f }
- T{ ##compare-imm f 2 1 f cc= }
- } value-numbering-step trim-temps
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer f 3 1 2 cc< }
+ } value-numbering-step
] unit-test
-! Reassociation
[
{
- 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{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##load-reference f 3 f }
}
] [
{
- 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 }
+ T{ ##load-integer f 1 10 }
+ T{ ##load-integer f 2 20 }
+ T{ ##compare-integer f 3 2 1 cc< }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 f }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc< }
} value-numbering-step
] unit-test
[
{
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{ ##copy f 1 0 any-rep }
+ T{ ##load-reference f 2 f }
}
] [
{
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 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##compare-integer f 2 0 1 cc< }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 t }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc<= }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 f }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc> }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 t }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc>= }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 f }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
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{ ##load-reference f 1 t }
}
] [
{
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 }
+ T{ ##compare-integer f 1 0 0 cc= }
} value-numbering-step
] unit-test
[
{
- 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{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 t }
}
] [
{
- 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 }
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 10 cc= }
} value-numbering-step
] unit-test
[
{
- 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{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 f }
}
] [
{
- 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 }
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 20 cc= }
} value-numbering-step
] unit-test
[
{
- 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{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 t }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 100 cc/= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##load-reference f 2 f }
+ }
+] [
+ {
+ T{ ##load-integer f 1 10 }
+ T{ ##compare-imm f 2 1 10 cc/= }
+ } value-numbering-step
+] unit-test
+
+cpu x86.32? [
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 f }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 + cc/= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 t }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 * cc/= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 t }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 + cc= }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##load-reference f 2 f }
+ }
+ ] [
+ {
+ T{ ##load-reference f 1 + }
+ T{ ##compare-imm f 2 1 * cc= }
+ } value-numbering-step
+ ] unit-test
+] when
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 f }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc/= }
+ } value-numbering-step
+] unit-test
+
+! Reassociation
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 50 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##sub f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##add-imm f 4 0 -150 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##sub f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##sub f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##mul f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##mul f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and-imm f 4 0 32 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and-imm f 4 0 32 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##and f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##and f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or-imm f 4 0 118 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or-imm f 4 0 118 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##or f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##or f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor f 2 0 1 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor f 4 2 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 100 }
+ T{ ##xor f 2 1 0 }
+ T{ ##load-integer f 3 50 }
+ T{ ##xor f 4 3 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shl-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sar-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 0 21 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##shr-imm f 1 0 10 }
+ T{ ##sar-imm f 2 1 11 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+! Distributive law
+2 \ vreg-counter set-global
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##shl-imm f 3 0 2 }
+ T{ ##add-imm f 2 3 40 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 2 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##mul-imm f 4 0 3 }
+ T{ ##add-imm f 2 4 30 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 10 }
+ T{ ##mul-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 -10 }
+ T{ ##shl-imm f 5 0 2 }
+ T{ ##add-imm f 2 5 -40 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sub-imm f 1 0 10 }
+ T{ ##shl-imm f 2 1 2 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##add-imm f 1 0 -10 }
+ T{ ##mul-imm f 6 0 3 }
+ T{ ##add-imm f 2 6 -30 }
+ T{ ##replace f 2 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##sub-imm f 1 0 10 }
+ T{ ##mul-imm f 2 1 3 }
+ T{ ##replace f 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+! Simplification
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##or-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##xor-imm f 3 0 0 }
+ T{ ##replace f 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##and-imm f 1 0 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##and-imm f 1 0 -1 }
+ T{ ##replace f 1 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##and f 1 0 0 }
+ T{ ##replace f 1 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##or-imm f 1 0 0 }
+ T{ ##replace f 1 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 1 -1 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##or-imm f 1 0 -1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##or f 1 0 0 }
+ T{ ##replace f 1 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
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 }
+ T{ ##xor-imm f 1 0 0 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
[
{
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{ ##not f 1 0 }
+ T{ ##replace f 1 D 0 }
}
] [
{
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 }
+ T{ ##xor-imm f 1 0 -1 }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
-! Simplification
[
{
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{ ##load-integer f 1 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 }
+ T{ ##xor f 1 0 0 }
} value-numbering-step
] unit-test
[
{
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{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 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 }
+ T{ ##mul-imm f 2 0 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
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{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 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 }
+ T{ ##shl-imm f 2 0 0 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
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{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 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 }
+ T{ ##shr-imm f 2 0 0 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
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 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##mul f 2 0 1 }
+ T{ ##sar-imm f 2 0 0 }
T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 4 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
T{ ##add f 3 1 2 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 3 }
T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 6 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
T{ ##mul f 3 1 2 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
+ T{ ##load-integer f 3 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
T{ ##and f 3 1 2 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
+ T{ ##load-integer f 3 3 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 1 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 1 }
T{ ##or f 3 1 2 }
} value-numbering-step
] unit-test
[
{
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{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
+ T{ ##load-integer f 3 1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 2 }
- T{ ##load-immediate f 2 3 }
+ T{ ##load-integer f 1 2 }
+ T{ ##load-integer f 2 3 }
T{ ##xor f 3 1 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 3 8 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 3 8 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##shl-imm f 3 1 3 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
- T{ ##load-immediate f 3 HEX: ffffffffffff }
+ T{ ##load-integer f 1 -1 }
+ T{ ##load-integer f 3 HEX: ffffffffffff }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -1 }
+ T{ ##load-integer f 1 -1 }
T{ ##shr-imm f 3 1 16 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -8 }
- T{ ##load-immediate f 3 -4 }
+ T{ ##load-integer f 1 -8 }
+ T{ ##load-integer f 3 -4 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 -8 }
+ T{ ##load-integer f 1 -8 }
T{ ##sar-imm f 3 1 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 65536 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 1 65536 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 65536 }
+ T{ ##load-integer f 1 65536 }
T{ ##shl-imm f 2 1 31 }
T{ ##add f 3 0 2 }
} value-numbering-step
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 140737488355328 }
+ T{ ##load-integer f 2 140737488355328 }
T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 2147483647 }
+ T{ ##load-integer f 2 2147483647 }
T{ ##add-imm f 3 0 2147483647 }
T{ ##add-imm f 4 3 2147483647 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 2147483647 }
+ T{ ##load-integer f 2 2147483647 }
T{ ##add f 3 0 2 }
T{ ##add f 4 3 2 }
} value-numbering-step
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 -1 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 -1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##neg f 2 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 -2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##not f 2 1 }
} value-numbering-step
] unit-test
-! Stupid constant folding corner case
-[
- {
- T{ ##load-constant f 1 f }
- T{ ##load-immediate f 2 $[ \ f type-number ] }
- }
-] [
- {
- T{ ##load-constant f 1 f }
- T{ ##and-imm f 2 1 15 }
- } value-numbering-step
-] unit-test
-
-! Displaced alien optimizations
-3 vreg-counter set-global
-
+! ##tagged>integer constant folding
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 1 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 4 0 }
- T{ ##add-imm f 3 4 16 }
+ T{ ##load-reference f 1 f }
+ T{ ##load-integer f 2 $[ \ f type-number ] }
+ T{ ##copy f 3 2 any-rep }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 1 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 3 1 }
+ T{ ##load-reference f 1 f }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##and-imm f 3 2 15 }
} value-numbering-step
] unit-test
-4 vreg-counter set-global
-
[
{
- T{ ##box-alien f 0 1 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##copy f 5 1 any-rep }
- T{ ##add-imm f 4 5 16 }
+ T{ ##load-integer f 1 100 }
+ T{ ##load-integer f 2 $[ 100 tag-fixnum ] }
+ T{ ##load-integer f 3 $[ 100 tag-fixnum 1 + ] }
}
] [
{
- T{ ##box-alien f 0 1 }
- T{ ##load-immediate f 2 16 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##unbox-any-c-ptr f 4 3 }
+ T{ ##load-integer f 1 100 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 1 }
} value-numbering-step
] unit-test
-3 vreg-counter set-global
-
+! Alien boxing and unboxing
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 0 }
- T{ ##copy f 3 0 any-rep }
- T{ ##replace f 3 D 1 }
+ T{ ##box-alien f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 2 0 }
- T{ ##box-displaced-alien f 3 2 0 c-ptr }
- T{ ##replace f 3 D 1 }
- } value-numbering-step
-] unit-test
-
-! Branch folding
-[
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##load-constant f 3 f }
- }
-] [
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##compare f 3 1 2 cc= }
- } value-numbering-step
-] unit-test
-
-[
- {
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-constant f 3 t }
- }
-] [
- {
- 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 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-constant f 3 t }
- }
-] [
- {
- 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 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##load-constant f 3 f }
- }
-] [
- {
- T{ ##load-immediate f 1 10 }
- T{ ##load-immediate f 2 20 }
- T{ ##compare f 3 2 1 cc< }
+ T{ ##box-alien f 1 0 }
+ T{ ##unbox-alien f 2 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 f }
+ T{ ##box-alien f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc< }
+ T{ ##box-alien f 1 0 }
+ T{ ##unbox-any-c-ptr f 2 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 1 D 0 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc<= }
+ T{ ##load-integer f 2 0 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##replace f 1 D 0 }
} value-numbering-step
] unit-test
-[
- {
- T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 f }
- }
-] [
- {
- T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc> }
- } value-numbering-step
-] unit-test
+3 vreg-counter set-global
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 0 }
+ T{ ##add-imm f 3 4 16 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc>= }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 1 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 3 1 }
} value-numbering-step
] unit-test
+4 vreg-counter set-global
+
[
{
- T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 f }
+ T{ ##box-alien f 0 1 }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##copy f 5 1 any-rep }
+ T{ ##add-imm f 4 5 16 }
}
] [
{
- T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc/= }
+ T{ ##box-alien f 0 1 }
+ T{ ##load-integer f 2 16 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##unbox-any-c-ptr f 4 3 }
} value-numbering-step
] unit-test
+3 vreg-counter set-global
+
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-integer f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 1 }
}
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare f 1 0 0 cc= }
+ T{ ##load-integer f 2 0 }
+ T{ ##box-displaced-alien f 3 2 0 c-ptr }
+ T{ ##replace f 3 D 1 }
} value-numbering-step
] unit-test
+! Various SIMD simplifications
[
{
T{ ##vector>scalar f 1 0 float-4-rep }
[
{
- T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
- T{ ##load-constant f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
- T{ ##copy f 2 1 any-rep }
+ T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
+ T{ ##load-reference f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
+ T{ ##load-reference f 2 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
}
] [
{
- T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
+ T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
T{ ##scalar>vector f 1 0 int-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
[
{
- T{ ##load-constant f 0 1.25 }
- T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
- T{ ##copy f 2 1 any-rep }
+ T{ ##load-reference f 0 1.25 }
+ T{ ##load-reference f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+ T{ ##load-reference f 2 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
}
] [
{
- T{ ##load-constant f 0 1.25 }
+ T{ ##load-reference f 0 1.25 }
T{ ##scalar>vector f 1 0 float-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
} value-numbering-step
] unit-test
-! branch folding
-
+! Branch folding
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##compare-branch f 1 2 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##compare-branch f 1 2 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare-branch f 1 2 cc< }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer-branch f 1 2 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##compare-branch f 2 1 cc< }
+ T{ ##load-integer f 1 1 }
+ T{ ##load-integer f 2 2 }
+ T{ ##compare-integer-branch f 2 1 cc< }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc< }
+ T{ ##compare-integer-branch f 0 0 cc< }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc<= }
+ T{ ##compare-integer-branch f 0 0 cc<= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc> }
+ T{ ##compare-integer-branch f 0 0 cc> }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc>= }
+ T{ ##compare-integer-branch f 0 0 cc>= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc= }
+ T{ ##compare-integer-branch f 0 0 cc= }
} test-branch-folding
] unit-test
] [
{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc/= }
+ T{ ##compare-integer-branch f 0 0 cc/= }
} test-branch-folding
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-constant f 1 t }
+ T{ ##load-reference f 1 t }
T{ ##branch }
}
0
V{
T{ ##peek f 0 D 0 }
- T{ ##compare-branch f 0 0 cc< }
+ T{ ##compare-integer-branch f 0 0 cc< }
} 1 test-bb
V{
- T{ ##load-immediate f 1 1 }
+ T{ ##load-integer f 1 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##load-immediate f 2 2 }
+ T{ ##load-integer f 2 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek f 1 D 1 }
- T{ ##compare-branch f 1 1 cc< }
+ T{ ##compare-integer-branch f 1 1 cc< }
} 1 test-bb
V{
} 2 test-bb
V{
- T{ ##phi f 3 V{ } }
+ T{ ##phi f 3 H{ { 1 1 } { 2 0 } } }
T{ ##branch }
} 3 test-bb
T{ ##return }
} 4 test-bb
-1 get 1 2array
-2 get 0 2array 2array 3 get instructions>> first (>>inputs)
-
test-diamond
[ ] [
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+! Slot addressing optimization
+cpu x86? [
+ [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 2 }
+ T{ ##slot f 3 0 1 $[ cell log2 ] $[ 7 2 cells - ] }
+ }
+ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##add-imm f 2 1 2 }
+ T{ ##slot f 3 0 2 $[ cell log2 ] 7 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+! Alien addressing optimization
+
+! Base offset fusion on ##load/store-memory-imm
+[
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 10 }
+ T{ ##load-memory-imm f 4 2 10 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 1 D 0 }
+ T{ ##tagged>integer f 2 1 }
+ T{ ##add-imm f 3 2 10 }
+ T{ ##load-memory-imm f 4 3 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##store-memory-imm f 2 3 10 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##store-memory-imm f 2 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement fusion on ##load/store-memory-imm
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##load-memory f 5 2 3 0 0 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##load-memory-imm f 5 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##store-memory f 5 2 3 0 0 int-rep c:uchar }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add f 4 2 3 }
+ T{ ##store-memory-imm f 5 4 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Base offset fusion on ##load/store-memory -- only on x86
+cpu x86?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 2 31337 }
+ T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
+ }
+]
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 2 31337 }
+ T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
+ }
+] ?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 2 31337 }
+ T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement offset fusion on ##load/store-memory -- only on x86
+cpu x86?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 31337 }
+ T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
+ }
+]
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 31337 }
+ T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
+ }
+] ?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 31337 }
+ T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+! Displacement offset fusion should not occur on
+! ##load/store-memory with non-zero scale
+[ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##add-imm f 4 3 10 }
+ T{ ##load-memory f 5 2 4 1 1 int-rep c:uchar }
+ } dup value-numbering-step assert=
+] unit-test
+
+! Scale fusion on ##load/store-memory
+cpu x86?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
+ }
+]
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+ }
+] ?
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+ } value-numbering-step
+] unit-test
+
+cpu x86? [
+ ! Don't do scale fusion if there's already a scale
+ [ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 2 }
+ T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
+ } dup value-numbering-step assert=
+ ] unit-test
+
+ ! Don't do scale fusion if the scale factor is out of range
+ [ ] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##tagged>integer f 2 0 }
+ T{ ##tagged>integer f 3 1 }
+ T{ ##shl-imm f 4 3 4 }
+ T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+ } dup value-numbering-step assert=
+ ] unit-test
+] when
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel accessors
-sorting sets sequences arrays
+USING: namespaces arrays assocs kernel accessors
+sorting sets sequences locals
cpu.architecture
sequences.deep
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
+compiler.cfg.utilities
compiler.cfg.instructions
+compiler.cfg.value-numbering.alien
+compiler.cfg.value-numbering.comparisons
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.rewrite ;
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.slots
+compiler.cfg.value-numbering.misc
+compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering
-! Local value numbering.
+GENERIC: process-instruction ( insn -- insn' )
-: >copy ( insn -- insn/##copy )
- dup defs-vreg dup vreg>vn vn>vreg
- 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
+: redundant-instruction ( insn vn -- insn' )
+ [ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
-GENERIC: process-instruction ( insn -- insn' )
+:: useful-instruction ( insn expr -- insn' )
+ insn dst>> :> vn
+ vn vn vregs>vns get set-at
+ vn expr exprs>vns get set-at
+ insn vn vns>insns get set-at
+ insn ;
+
+: check-redundancy ( insn -- insn' )
+ dup >expr dup exprs>vns get at
+ [ redundant-instruction ] [ useful-instruction ] ?if ;
M: insn process-instruction
dup rewrite
[ process-instruction ]
- [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
+ [ dup defs-vreg [ check-redundancy ] when ] ?if ;
+
+M: ##copy process-instruction
+ dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
M: array process-instruction
[ process-instruction ] map ;
init-value-graph
[ process-instruction ] map flatten ;
-: value-numbering ( cfg -- cfg' )
- [ value-numbering-step ] local-optimization
+: value-numbering ( cfg -- cfg )
+ dup [ value-numbering-step ] simple-optimization
cfg-changed predecessors-changed ;
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators.short-circuit
compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
M: insn eliminate-write-barrier drop t ;
-: write-barriers-step ( bb -- )
+: write-barriers-step ( insns -- insns' )
H{ } clone fresh-allocations set
H{ } clone mutated-objects set
- instructions>> [ eliminate-write-barrier ] filter! drop ;
+ [ eliminate-write-barrier ] filter! ;
-: eliminate-write-barriers ( cfg -- cfg' )
- dup [ write-barriers-step ] each-basic-block ;
+: eliminate-write-barriers ( cfg -- cfg )
+ dup [ write-barriers-step ] simple-optimization ;
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.complex alien.c-types
+alien.libraries alien.private alien.strings arrays
+classes.struct combinators compiler.alien
+compiler.cfg.instructions compiler.codegen
+compiler.codegen.fixup compiler.errors compiler.utilities
+cpu.architecture fry kernel layouts libc locals make math
+math.order math.parser namespaces quotations sequences strings ;
+FROM: compiler.errors => no-such-symbol ;
+IN: compiler.codegen.alien
+
+! ##alien-invoke
+GENERIC: next-fastcall-param ( rep -- )
+
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+ drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-rep next-fastcall-param
+ int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
+
+M: float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+M: double-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
+
+M: stack-params reg-class-full? 2drop t ;
+
+M: reg-class reg-class-full?
+ [ get ] swap '[ _ param-regs length ] bi >= ;
+
+: alloc-stack-param ( rep -- n reg-class rep )
+ stack-params get
+ [ rep-size cell align stack-params +@ ] dip
+ stack-params dup ;
+
+: alloc-fastcall-param ( rep -- n reg-class rep )
+ [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
+
+:: alloc-parameter ( parameter abi -- reg rep )
+ parameter c-type-rep dup reg-class-of abi reg-class-full?
+ [ alloc-stack-param ] [ alloc-fastcall-param ] if
+ [ abi param-reg ] dip ;
+
+SYMBOL: (stack-value)
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
+
+: ((flatten-type)) ( type to-type -- seq )
+ [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
+
+: (flatten-int-type) ( type -- seq )
+ void* ((flatten-type)) ;
+: (flatten-stack-type) ( type -- seq )
+ (stack-value) ((flatten-type)) ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+M: struct-c-type flatten-value-type (flatten-int-type) ;
+M: long-long-type flatten-value-type (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align cell /i void* c-type <repetition> % ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type %
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ [ [ parameter-offsets nip ] keep ] dip 2each ; inline
+
+: 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-fastcall-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+ [ '[ _ alloc-parameter _ execute ] ]
+ bi* each-parameter ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+
+: prepare-unbox-parameters ( parameters -- offsets types indices )
+ [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
+
+: unbox-parameters ( offset node -- )
+ parameters>> swap
+ '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
+ [ length neg %inc-d ]
+ bi ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to registers on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return %push-stack ] if-void ;
+
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd dlsym-valid?
+ [ drop ] [ compiling-word get no-such-symbol ] if
+ ] [
+ dll-path compiling-word get no-such-library drop
+ ] if ;
+
+: decorated-symbol ( params -- symbols )
+ [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+ {
+ [ drop ]
+ [ "@" glue ]
+ [ "@" glue "_" prepend ]
+ [ "@" glue "@" prepend ]
+ } 2cleave
+ 4array ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
+ [ library>> load-library ]
+ bi 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+ params>>
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+M: ##alien-assembly generate-insn
+ params>>
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Generate assembly
+ dup quot>> call( -- )
+ ! Box return value
+ box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+ params>>
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
+
+: registers>objects ( node -- )
+ ! Generate code for boxing input parameters in a callback.
+ [
+ dup \ %save-param-reg move-parameters
+ %begin-callback
+ box-parameters
+ ] with-param-regs ;
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup void? ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
+ yield-hook get
+ '[ _ _ do-callback ]
+ >quotation ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
--- /dev/null
+Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences
accessors kernel layouts assocs words summary arrays combinators
-classes.algebra alien alien.private alien.c-types alien.strings
-alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes
-classes.struct locals source-files.errors slots parser
-generic.parser strings quotations
-compiler.errors
-compiler.alien
+classes.algebra sets continuations.private fry cpu.architecture
+classes classes.struct locals slots parser generic.parser
+strings quotations hashtables
compiler.constants
compiler.cfg
+compiler.cfg.linearization
compiler.cfg.instructions
+compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
FROM: namespaces => set ;
-FROM: compiler.errors => no-such-symbol ;
IN: compiler.codegen
SYMBOL: insn-counts
GENERIC: generate-insn ( insn -- )
-! Mapping _label IDs to label instances
+! Control flow
SYMBOL: labels
-: generate ( mr -- code )
- dup label>> [
- H{ } clone labels set
+: lookup-label ( bb -- label )
+ labels get [ drop <label> ] cache ;
+
+: useless-branch? ( bb successor -- ? )
+ ! If our successor immediately follows us in linearization
+ ! order then we don't need to branch.
+ [ block-number ] bi@ 1 - = ; inline
+
+: emit-branch ( bb successor -- )
+ 2dup useless-branch?
+ [ 2drop ] [ nip lookup-label %jump-label ] if ;
+
+M: ##branch generate-insn
+ drop basic-block get dup successors>> first emit-branch ;
+
+GENERIC: generate-conditional-insn ( label insn -- )
+
+GENERIC: negate-insn-cc ( insn -- )
+
+M: conditional-branch-insn negate-insn-cc
+ [ negate-cc ] change-cc drop ;
+
+M: ##test-vector-branch negate-insn-cc
+ [ negate-vcc ] change-vcc drop ;
+
+M:: conditional-branch-insn generate-insn ( insn -- )
+ basic-block get :> bb
+ bb successors>> first2 :> ( first second )
+ bb second useless-branch?
+ [ bb second first ]
+ [ bb first second insn negate-insn-cc ] if
+ lookup-label insn generate-conditional-insn
+ emit-branch ;
+
+: %dispatch-label ( label -- )
+ cell 0 <repetition> %
+ rc-absolute-cell label-fixup ;
+
+M: ##dispatch generate-insn
+ [ src>> ] [ temp>> ] bi %dispatch
+ basic-block get successors>>
+ [ lookup-label %dispatch-label ] each ;
+
+: generate-block ( bb -- )
+ [ basic-block set ]
+ [ lookup-label resolve-label ]
+ [
instructions>> [
[ class insn-counts get inc-at ]
[ generate-insn ]
bi
] each
- ] with-fixup ;
+ ] tri ;
-: lookup-label ( id -- label )
- labels get [ drop <label> ] cache ;
+: generate ( cfg -- code )
+ dup label>> [
+ H{ } clone labels set
+ linearization-order
+ [ number-blocks ] [ [ generate-block ] each ] bi
+ ] with-fixup ;
! Special cases
M: ##no-tco generate-insn drop ;
-M: _dispatch-label generate-insn
- label>> lookup-label
- cell 0 <repetition> %
- rc-absolute-cell label-fixup ;
-
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+M: ##prologue generate-insn
+ drop
+ cfg get stack-frame>>
+ [ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: _spill-area-size generate-insn drop ;
+M: ##epilogue generate-insn
+ drop
+ cfg get stack-frame>> [ total-size>> %epilogue ] when* ;
! Some meta-programming to generate simple code generators, where
! the instruction is unpacked and then a %word is called
<<
: insn-slot-quot ( spec -- quot )
- name>> [ reader-word ] [ "label" = ] bi
- [ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
+ name>> reader-word 1quotation ;
: codegen-method-body ( class word -- quot )
[
SYNTAX: CODEGEN:
scan-word [ \ generate-insn create-method-in ] keep scan-word
codegen-method-body define ;
+
>>
-CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-integer %load-immediate
+CODEGEN: ##load-tagged %load-immediate
CODEGEN: ##load-reference %load-reference
-CODEGEN: ##load-constant %load-reference
CODEGEN: ##load-double %load-double
+CODEGEN: ##load-vector %load-vector
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
+CODEGEN: ##replace-imm %replace-imm
CODEGEN: ##inc-d %inc-d
CODEGEN: ##inc-r %inc-r
CODEGEN: ##call %call
CODEGEN: ##slot-imm %slot-imm
CODEGEN: ##set-slot %set-slot
CODEGEN: ##set-slot-imm %set-slot-imm
-CODEGEN: ##string-nth %string-nth
-CODEGEN: ##set-string-nth-fast %set-string-nth-fast
CODEGEN: ##add %add
CODEGEN: ##add-imm %add-imm
CODEGEN: ##sub %sub
CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
+CODEGEN: ##tagged>integer %tagged>integer
CODEGEN: ##add-float %add-float
CODEGEN: ##sub-float %sub-float
CODEGEN: ##mul-float %mul-float
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
-CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
-CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
-CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
-CODEGEN: ##alien-signed-1 %alien-signed-1
-CODEGEN: ##alien-signed-2 %alien-signed-2
-CODEGEN: ##alien-signed-4 %alien-signed-4
-CODEGEN: ##alien-cell %alien-cell
-CODEGEN: ##alien-float %alien-float
-CODEGEN: ##alien-double %alien-double
-CODEGEN: ##alien-vector %alien-vector
-CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
-CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
-CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
-CODEGEN: ##set-alien-cell %set-alien-cell
-CODEGEN: ##set-alien-float %set-alien-float
-CODEGEN: ##set-alien-double %set-alien-double
-CODEGEN: ##set-alien-vector %set-alien-vector
+CODEGEN: ##load-memory %load-memory
+CODEGEN: ##load-memory-imm %load-memory-imm
+CODEGEN: ##store-memory %store-memory
+CODEGEN: ##store-memory-imm %store-memory-imm
CODEGEN: ##allot %allot
CODEGEN: ##write-barrier %write-barrier
CODEGEN: ##write-barrier-imm %write-barrier-imm
CODEGEN: ##compare %compare
CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-integer %compare
+CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
+CODEGEN: ##alien-global %alien-global
+CODEGEN: ##call-gc %call-gc
+CODEGEN: ##spill %spill
+CODEGEN: ##reload %reload
-CODEGEN: _fixnum-add %fixnum-add
-CODEGEN: _fixnum-sub %fixnum-sub
-CODEGEN: _fixnum-mul %fixnum-mul
-CODEGEN: _label resolve-label
-CODEGEN: _branch %jump-label
-CODEGEN: _compare-branch %compare-branch
-CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
-CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
-CODEGEN: _test-vector-branch %test-vector-branch
-CODEGEN: _dispatch %dispatch
-CODEGEN: _spill %spill
-CODEGEN: _reload %reload
-
-! ##gc
-: wipe-locs ( locs temp -- )
- '[
- _
- [ 0 %load-immediate ]
- [ swap [ %replace ] with each ] bi
- ] unless-empty ;
-
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp int-rep operand %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 int-rep operand %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 [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ]
- [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
- [ data-values>> save-data-regs ]
- [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
- [ [ temp1>> ] [ temp2>> ] bi %save-context ]
- [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
- [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
- [ data-values>> load-data-regs ]
- } cleave
- "no-gc" resolve-label ;
-
-M: _loop-entry generate-insn drop %loop-entry ;
-
-M: ##alien-global generate-insn
- [ dst>> ] [ symbol>> ] [ library>> ] tri
- %alien-global ;
-
-! ##alien-invoke
-GENERIC: next-fastcall-param ( rep -- )
-
-: ?dummy-stack-params ( rep -- )
- dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-
-: ?dummy-int-params ( rep -- )
- dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( rep -- )
- drop dummy-fp-params? [ float-regs inc ] when ;
-
-M: int-rep next-fastcall-param
- int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-
-M: float-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-M: double-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-
-M: stack-params reg-class-full? 2drop t ;
-
-M: reg-class reg-class-full?
- [ get ] swap '[ _ param-regs length ] bi >= ;
-
-: alloc-stack-param ( rep -- n reg-class rep )
- stack-params get
- [ rep-size cell align stack-params +@ ] dip
- stack-params dup ;
-
-: alloc-fastcall-param ( rep -- n reg-class rep )
- [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-
-:: alloc-parameter ( parameter abi -- reg rep )
- parameter c-type-rep dup reg-class-of abi reg-class-full?
- [ alloc-stack-param ] [ alloc-fastcall-param ] if
- [ abi param-reg ] dip ;
-
-SYMBOL: (stack-value)
-<< void* c-type clone \ (stack-value) define-primitive-type
-stack-params \ (stack-value) c-type (>>rep) >>
-
-: ((flatten-type)) ( type to-type -- seq )
- [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
-
-: (flatten-int-type) ( type -- seq )
- void* ((flatten-type)) ;
-: (flatten-stack-type) ( type -- seq )
- (stack-value) ((flatten-type)) ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: long-long-type flatten-value-type (flatten-int-type) ;
-M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- 0 [
- c-type
- [ parameter-align cell /i void* c-type <repetition> % ] keep
- [ stack-size cell align + ] keep
- flatten-value-type %
- ] reduce drop
- ] { } make ;
-
-: each-parameter ( parameters quot -- )
- [ [ parameter-offsets nip ] keep ] dip 2each ; inline
-
-: 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-fastcall-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
- #! Moves values from C stack to registers (if word is
- #! %load-param-reg) and registers to C stack (if word is
- #! %save-param-reg).
- [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
- [ '[ _ alloc-parameter _ execute ] ]
- bi* each-parameter ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
-
-: prepare-unbox-parameters ( parameters -- offsets types indices )
- [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
-
-: unbox-parameters ( offset node -- )
- parameters>> swap
- '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
- [ length neg %inc-d ]
- bi ;
-
-: prepare-box-struct ( node -- offset )
- #! Return offset on C stack where to store unboxed
- #! parameters. If the C function is returning a structure,
- #! the first parameter is an implicit target area pointer,
- #! so we need to use a different offset.
- return>> large-struct?
- [ %prepare-box-struct cell ] [ 0 ] if ;
-
-: objects>registers ( params -- )
- #! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to registers on
- #! architectures where parameters are passed in registers.
- [
- [ prepare-box-struct ] keep
- [ unbox-parameters ] keep
- \ %load-param-reg move-parameters
- ] with-param-regs ;
-
-: box-return* ( node -- )
- return>> [ ] [ box-return %push-stack ] if-void ;
-
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
-
-M: string dlsym-valid? dlsym ;
-
-M: array dlsym-valid? '[ _ dlsym ] any? ;
-
-: check-dlsym ( symbols dll -- )
- dup dll-valid? [
- dupd dlsym-valid?
- [ drop ] [ compiling-word get no-such-symbol ] if
- ] [
- dll-path compiling-word get no-such-library drop
- ] if ;
-
-: decorated-symbol ( params -- symbols )
- [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
- {
- [ drop ]
- [ "@" glue ]
- [ "@" glue "_" prepend ]
- [ "@" glue "@" prepend ]
- } 2cleave
- 4array ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
- [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
- [ library>> load-library ]
- bi 2dup check-dlsym ;
-
-M: ##alien-invoke generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call function
- dup alien-invoke-dlsym %alien-invoke
- ! Box return value
- dup %cleanup
- box-return* ;
-
-M: ##alien-assembly generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Generate assembly
- dup quot>> call( -- )
- ! Box return value
- box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
- params>>
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##alien-callback
-: box-parameters ( params -- )
- alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
-
-: registers>objects ( node -- )
- ! Generate code for boxing input parameters in a callback.
- [
- dup \ %save-param-reg move-parameters
- %begin-callback
- box-parameters
- ] with-param-regs ;
-
-: callback-return-quot ( ctype -- quot )
- return>> {
- { [ dup void? ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
- [ c-type c-type-unboxer-quot ]
- } cond ;
+<<
-: callback-prep-quot ( params -- quot )
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+SYNTAX: CONDITIONAL:
+ scan-word [ \ generate-conditional-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
-: wrap-callback-quot ( params -- quot )
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
- yield-hook get
- '[ _ _ do-callback ]
- >quotation ;
+>>
-M: ##alien-callback generate-insn
- params>>
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
+CONDITIONAL: ##compare-branch %compare-branch
+CONDITIONAL: ##compare-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-branch %compare-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-integer-imm-branch
+CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
+CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
+CONDITIONAL: ##test-vector-branch %test-vector-branch
+CONDITIONAL: ##check-nursery-branch %check-nursery-branch
+CONDITIONAL: ##fixnum-add %fixnum-add
+CONDITIONAL: ##fixnum-sub %fixnum-sub
+CONDITIONAL: ##fixnum-mul %fixnum-mul
accessors growable fry compiler.constants memoize ;
IN: compiler.codegen.fixup
+! Utilities
+: push-uint ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+: push-double ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-double ;
+
! Owner
SYMBOL: compiling-word
! Relocation table
SYMBOL: relocation-table
-: push-4 ( value vector -- )
- [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
- swap set-alien-unsigned-4 ;
-
: add-relocation-entry ( type class offset -- )
- { 0 24 28 } bitfield relocation-table get push-4 ;
+ { 0 24 28 } bitfield relocation-table get push-uint ;
: rel-fixup ( class type -- )
swap compiled-offset add-relocation-entry ;
+! Binary literal table
+SYMBOL: binary-literal-table
+
+: add-binary-literal ( obj -- label )
+ <label> [ 2array binary-literal-table get push ] keep ;
+
! Caching common symbol names reduces image size a bit
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: rel-literal ( literal class -- )
[ add-literal ] dip rt-literal rel-fixup ;
-: rel-float ( literal class -- )
- [ add-literal ] dip rt-float rel-fixup ;
+: rel-binary-literal ( literal class -- )
+ [ add-binary-literal ] dip label-fixup ;
: rel-this ( class -- )
rt-this rel-fixup ;
rt-decks-offset rel-fixup ;
! And the rest
-: resolve-offset ( label-fixup -- offset )
+: compute-target ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
-: resolve-absolute-label ( label-fixup -- )
- dup resolve-offset neg add-literal
- [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+: compute-relative-label ( label-fixup -- label )
+ [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
-: resolve-relative-label ( label-fixup -- label )
- [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+: compute-absolute-label ( label-fixup -- )
+ [ compute-target neg add-literal ]
+ [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
-: resolve-labels ( label-fixups -- labels' )
+: compute-labels ( label-fixups -- labels' )
[ class>> rc-absolute? ] partition
- [ [ resolve-absolute-label ] each ]
- [ [ resolve-relative-label ] map concat ]
+ [ [ compute-absolute-label ] each ]
+ [ [ compute-relative-label ] map concat ]
bi* ;
: init-fixup ( word -- )
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
- BV{ } clone relocation-table set ;
+ BV{ } clone relocation-table set
+ V{ } clone binary-literal-table set ;
+
+: alignment ( align -- n )
+ [ compiled-offset dup ] dip align swap - ;
+
+: (align-code) ( n -- )
+ 0 <repetition> % ;
+
+: align-code ( n -- )
+ alignment (align-code) ;
+
+GENERIC# emit-data 1 ( obj label -- )
+
+M: float emit-data
+ 8 align-code
+ resolve-label
+ building get push-double ;
+
+M: byte-array emit-data
+ 16 align-code
+ resolve-label
+ building get push-all ;
+
+: emit-binary-literals ( -- )
+ binary-literal-table get [ emit-data ] assoc-each ;
: with-fixup ( word quot -- code )
'[
init-fixup
@
- label-table [ resolve-labels ] change
+ emit-binary-literals
+ label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
-compiler.cfg.mr
+compiler.cfg.finalization
-compiler.codegen ;
+compiler.codegen
+compiler.codegen.alien ;
IN: compiler
SYMBOL: compiled
: backend ( tree word -- )
build-cfg [
- [ optimize-cfg build-mr ] with-cfg
- [ generate ] [ label>> ] bi compiled get set-at
+ [
+ optimize-cfg finalize-cfg
+ [ generate ] [ label>> ] bi compiled get set-at
+ ] with-cfg
] each ;
: compile-word ( word -- )
CONSTANT: rt-cards-offset 10
CONSTANT: rt-decks-offset 11
CONSTANT: rt-exception-handler 12
-CONSTANT: rt-float 13
: rc-absolute? ( n -- ? )
${
1 1
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
] unit-test
+
+! GC root offsets were computed wrong on x86
+: gc-root-messup ( a -- b )
+ dup [
+ 1024 (byte-array) 2array
+ 10 void* "libc" "malloc" { ulong } alien-invoke
+ void "libc" "free" { void* } alien-invoke
+ ] when ;
+
+[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
USING: compiler.units compiler.test kernel kernel.private memory
math math.private tools.test math.floats.private math.order fry
-;
+specialized-arrays sequences ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
-! Ensure that float-min and min, and float-max and max, have
-! consistent behavior with respect to NaNs
-
: two-floats ( a b -- a b ) { float float } declare ; inline
[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
-: check-compiled-binary-op ( a b word -- )
- [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
- [ '[ _ execute ] ]
- bi 2bi fp-bitwise= ; inline
-
-[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
-[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
-[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
-[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test
+! Test loops
+[ 30.0 ] [
+ float-array{ 1 2 3 4 } float-array{ 1 2 3 4 }
+ [ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-array{ 1 2 3 4 }
+ [ { float-array } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-array{ 1 2 3 4 }
+ [ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call
+] unit-test
+
+[ 4.5 ] [
+ float-array{ 1.0 3.5 }
+ [ { float-array } declare 0.0 [ + ] reduce ] compile-call
+] unit-test
+
+[ float-array{ 2.0 4.5 } ] [
+ float-array{ 1.0 3.5 }
+ [ { float-array } declare [ 1 + ] map ] compile-call
+] unit-test
USING: accessors assocs compiler compiler.cfg
-compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
-compiler.cfg.registers compiler.codegen compiler.units
-cpu.architecture hashtables kernel namespaces sequences
-tools.test vectors words layouts literals math arrays
-alien.syntax math.private ;
+compiler.cfg.debugger compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.linear-scan
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.codegen compiler.units cpu.architecture hashtables
+kernel namespaces sequences tools.test vectors words layouts
+literals math arrays alien.c-types alien.syntax math.private ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
gensym
- [ build-mr generate ] dip
+ [ linear-scan build-stack-frame generate ] dip
[ associate >alist t t modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
cfg new 0 get >>entry
dup cfg set
- dup fake-representations representations get >>reps
+ dup fake-representations
+ destruct-ssa
compile-cfg ;
: compile-test-bb ( insns -- result )
execute( -- result ) ;
! loading constants
-[ f ] [
- V{
- T{ ##load-constant f 0 f }
- } compile-test-bb
-] unit-test
-
[ "hello" ] [
V{
T{ ##load-reference f 0 "hello" }
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+ T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##slot f 0 0 1 }
+ T{ ##slot f 0 0 1 0 0 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+ T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
- T{ ##set-slot f 0 0 1 }
+ T{ ##set-slot f 0 0 1 0 0 }
} compile-test-bb
dup first eq?
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f 0 4 }
+ T{ ##load-tagged f 0 4 }
T{ ##shl f 0 0 0 }
} compile-test-bb
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f 0 4 }
+ T{ ##load-tagged f 0 4 }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 }
- T{ ##alien-unsigned-1 f 0 0 0 }
- T{ ##shl-imm f 0 0 4 }
- } compile-test-bb
-] unit-test
-
-[ CHAR: l ] [
- V{
- T{ ##load-reference f 0 "hello world" }
- T{ ##load-immediate f 1 3 }
- T{ ##string-nth f 0 0 1 2 }
+ T{ ##load-memory-imm f 0 0 0 int-rep uchar }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-immediate f 0 32 }
+ T{ ##load-tagged f 0 32 }
T{ ##add-imm f 0 0 -16 }
} compile-test-bb
] unit-test
2bi and maybe-or-never
] "outputs" set-word-prop
-\ both-fixnums? [
- [ class>> ] bi@ {
- { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
- { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
- [ object-info ]
- } cond 2nip
-] "outputs" set-word-prop
-
{
{ >fixnum fixnum }
{ bignum>fixnum fixnum }
] "outputs" set-word-prop
] each
-\ string-nth [
- 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+\ string-nth-fast [
+ 2drop fixnum 0 255 [a,b] <class/interval-info>
] "outputs" set-word-prop
{
compiler.tree.debugger compiler.tree.checker slots.private words
hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private
-math.intervals quotations effects alien alien.data sets ;
+math.intervals quotations effects alien alien.data sets
+strings.private ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
[ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
[ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
+
+! Output range for string-nth now that string-nth is a library word and
+! not a primitive
+[ t ] [
+ ! Should actually be 0 23 2^ 1 - [a,b]
+ [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
+] unit-test
[ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
] 1 define-partial-eval
+
+! Eliminates a few redundant checks here and there
+\ both-fixnums? [
+ in-d>> first2 [ value-info class>> ] bi@ {
+ { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
+ { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
+ { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
+ { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
+ [ f ]
+ } cond 2nip
+] "custom-inlining" set-word-prop
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io kernel math namespaces
-prettyprint sequences vectors ;
+sequences vectors ;
QUALIFIED-WITH: bitstreams bs
IN: compression.lzw
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets fry ;
+math math.order 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
int-vector-rep
float-vector-rep ;
+CONSTANT: vector-reps
+ {
+ char-16-rep
+ uchar-16-rep
+ short-8-rep
+ ushort-8-rep
+ int-4-rep
+ uint-4-rep
+ longlong-2-rep
+ ulonglong-2-rep
+ float-4-rep
+ double-2-rep
+ }
+
UNION: representation
any-rep
tagged-rep
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
+! Specifies if %slot, %set-slot and %write-barrier accept the
+! 'scale' and 'tag' parameters, and if %load-memory and
+! %store-memory work
+HOOK: complex-addressing? cpu ( -- ? )
+
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-double cpu ( reg val -- )
+HOOK: %load-vector cpu ( reg val rep -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
+HOOK: %replace-imm cpu ( src loc -- )
HOOK: %inc-d cpu ( n -- )
HOOK: %inc-r cpu ( n -- )
HOOK: %dispatch cpu ( src temp -- )
-HOOK: %slot cpu ( dst obj slot -- )
+HOOK: %slot cpu ( dst obj slot scale tag -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot -- )
+HOOK: %set-slot cpu ( src obj slot scale tag -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
-HOOK: %string-nth cpu ( dst obj index temp -- )
-HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
-
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )
HOOK: %copy cpu ( dst src rep -- )
-HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
+: %tagged>integer ( dst src -- ) int-rep %copy ;
+
+HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
-HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
-HOOK: %alien-signed-1 cpu ( dst src offset -- )
-HOOK: %alien-signed-2 cpu ( dst src offset -- )
-HOOK: %alien-signed-4 cpu ( dst src offset -- )
-HOOK: %alien-cell cpu ( dst src offset -- )
-HOOK: %alien-float cpu ( dst src offset -- )
-HOOK: %alien-double cpu ( dst src offset -- )
-HOOK: %alien-vector cpu ( dst src offset rep -- )
-
-HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
-HOOK: %set-alien-cell cpu ( ptr offset value -- )
-HOOK: %set-alien-float cpu ( ptr offset value -- )
-HOOK: %set-alien-double cpu ( ptr offset value -- )
-HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
+HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
+HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
+HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )
+HOOK: %store-memory-imm cpu ( value base offset rep c-type -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
-HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
-HOOK: %write-barrier-imm cpu ( src slot temp1 temp2 -- )
+HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
+HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
! GC checks
-HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
-HOOK: %save-gc-root cpu ( gc-root register -- )
-HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count temp1 -- )
+HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
+HOOK: %call-gc cpu ( gc-roots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-integer-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
M: stack-params param-reg 2drop ;
-! Does this architecture support %load-double?
-HOOK: load-double? cpu ( -- ? )
-
-M: object load-double? f ;
+! Does this architecture support %load-double, %load-vector and
+! objects in %compare-imm?
+HOOK: fused-unboxing? cpu ( -- ? )
! Can this value be an immediate operand for %add-imm, %sub-imm,
! or %mul-imm?
! %compare-imm-branch?
HOOK: immediate-comparand? cpu ( n -- ? )
+! Can this value be an immediate operand for %replace-imm?
+HOOK: immediate-store? cpu ( obj -- ? )
+
M: object immediate-comparand? ( n -- ? )
{
- { [ dup integer? ] [ immediate-arithmetic? ] }
+ { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond ;
+: immediate-shift-count? ( n -- ? )
+ 0 cell-bits 1 - between? ;
+
! What c-type describes the implicit struct return pointer for
! large structs?
HOOK: struct-return-pointer-type cpu ( -- c-type )
HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
+HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
+HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
+HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
+HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
+HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
+HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
+HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
HEX{ 48 00 00 01 } [ 1 B ] test-assembler
HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
X: FCMPU 0 0 63
X: LBZUX 0 119 31
X: LBZX 0 87 31
+X: LFDUX 0 631 31
+X: LFDX 0 599 31
+X: LFSUX 0 567 31
+X: LFSX 0 535 31
X: LHAUX 0 375 31
X: LHAX 0 343 31
X: LHZUX 0 311 31
X: SRW. 1 536 31
X: STBUX 0 247 31
X: STBX 0 215 31
+X: STFDUX 0 759 31
+X: STFDX 0 727 31
+X: STFSUX 0 695 31
+X: STFSX 0 663 31
X: STHUX 0 439 31
X: STHX 0 407 31
X: STWUX 0 183 31
system cpu.ppc.assembler compiler.units compiler.constants math\r
math.private math.ranges layouts words vocabs slots.private\r
locals locals.backend generic.single.private fry sequences\r
-threads.private ;\r
+threads.private strings.private ;\r
FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
3 ds-reg 0 STW\r
] \ slot define-sub-primitive\r
\r
+[\r
+ ! load string index from stack\r
+ 3 ds-reg -4 LWZ\r
+ 3 3 tag-bits get SRAWI\r
+ ! load string from stack\r
+ 4 ds-reg 0 LWZ\r
+ ! load character\r
+ 4 4 string-offset ADDI\r
+ 3 3 4 LBZX\r
+ 3 3 tag-bits get SLWI\r
+ ! store character to stack\r
+ ds-reg ds-reg 4 SUBI\r
+ 3 ds-reg 0 STW\r
+] \ string-nth-fast define-sub-primitive\r
+\r
! Shufflers\r
[\r
ds-reg dup 4 SUBI\r
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences kernel combinators make math
-math.order math.ranges system namespaces locals layouts words
-alien alien.accessors alien.c-types alien.complex alien.data
-literals cpu.architecture cpu.ppc.assembler
-cpu.ppc.assembler.backend compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.comparisons
-compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame compiler.cfg.build-stack-frame
-compiler.units compiler.constants compiler.codegen vm ;
+USING: accessors assocs sequences kernel combinators
+classes.algebra byte-arrays make math math.order math.ranges
+system namespaces locals layouts words alien alien.accessors
+alien.c-types alien.complex alien.data literals cpu.architecture
+cpu.ppc.assembler cpu.ppc.assembler.backend
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.comparisons compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+compiler.cfg.build-stack-frame compiler.units compiler.constants
+compiler.codegen vm ;
+QUALIFIED-WITH: alien.c-types c
FROM: cpu.ppc.assembler => B ;
FROM: layouts => cell ;
FROM: math => float ;
enable-float-intrinsics
<<
-\ ##integer>float t frame-required? set-word-prop
-\ ##float>integer t frame-required? set-word-prop
+\ ##integer>float t "frame-required?" set-word-prop
+\ ##float>integer t "frame-required?" set-word-prop
>>
M: ppc machine-registers
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
+M: ppc complex-addressing? f ;
+
+M: ppc fused-unboxing? f ;
+
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
- [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
+ [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
+ [ \ f type-number swap LI ]
+ if* ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
: scratch@ ( n -- offset )
factor-area-size + ;
-! GC root area
-: gc-root@ ( n -- offset )
- gc-root-offset local@ ;
-
! Finally we have the linkage area
HOOK: lr-save os ( -- n )
temp MTCTR
BCTR ;
-M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
+: (%slot) ( dst obj slot scale tag -- obj dst slot )
+ [ 0 assert= ] bi@ swapd ;
+
+M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
-M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
+M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
-M:: ppc %string-nth ( dst src index temp -- )
- [
- "end" define-label
- temp src index ADD
- dst temp string-offset LBZ
- 0 dst HEX: 80 CMPI
- "end" get BLT
- temp src string-aux-offset LWZ
- temp temp index ADD
- temp temp index ADD
- temp temp byte-array-offset LHZ
- temp temp 7 SLWI
- dst dst temp XOR
- "end" resolve-label
- ] with-scope ;
-
-M:: ppc %set-string-nth-fast ( ch obj index temp -- )
- temp obj index ADD
- ch temp string-offset STB ;
-
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swap SUBF ;
M: ppc %not NOT ;
M: ppc %neg NEG ;
-:: overflow-template ( label dst src1 src2 insn -- )
+:: overflow-template ( label dst src1 src2 cc insn -- )
0 0 LI
0 MTXER
dst src2 src1 insn call
- label BO ; inline
+ cc {
+ { cc-o [ label BO ] }
+ { cc/o [ label BNO ] }
+ } case ; inline
-M: ppc %fixnum-add ( label dst src1 src2 -- )
+M: ppc %fixnum-add ( label dst src1 src2 cc -- )
[ ADDO. ] overflow-template ;
-M: ppc %fixnum-sub ( label dst src1 src2 -- )
+M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
[ SUBFO. ] overflow-template ;
-M: ppc %fixnum-mul ( label dst src1 src2 -- )
+M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLWO. ] overflow-template ;
M: ppc %add-float FADD ;
M: ppc %copy ( dst src rep -- )
2over eq? [ 3drop ] [
{
+ { tagged-rep [ MR ] }
{ int-rep [ MR ] }
{ double-rep [ FMR ] }
} case
"f" resolve-label
] with-scope ;
+:: %box-displaced-alien/f ( dst displacement base -- )
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ displacement dst 4 alien@ STW ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+ ! Set new alien's base to base.base
+ temp base 1 alien@ LWZ
+ temp dst 1 alien@ STW
+
+ ! Compute displacement
+ temp base 3 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 3 alien@ STW
+
+ ! Compute address
+ temp base 4 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 4 alien@ STW ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ temp base byte-array-offset ADDI
+ temp temp displacement ADD
+ temp dst 4 alien@ STW ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
+ "not-f" define-label
+ "not-alien" define-label
+
+ ! Is base f?
+ 0 base \ f type-number CMPI
+ "not-f" get BNE
+
+ ! Yes, it is f. Fill in new object
+ dst displacement base %box-displaced-alien/f
+
+ "end" get B
+
+ "not-f" resolve-label
+
+ ! Check base type
+ temp base tag-mask get ANDI
+
+ ! Is base an alien?
+ 0 temp alien type-number CMPI
+ "not-alien" get BNE
+
+ dst displacement base temp %box-displaced-alien/alien
+
+ ! We are done
+ "end" get B
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst displacement base temp %box-displaced-alien/byte-array ;
+
M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
! This is ridiculous
[
"end" define-label
- "not-f" define-label
- "not-alien" define-label
! If displacement is zero, return the base
dst base MR
temp \ f type-number %load-immediate
temp dst 2 alien@ STW
- ! Is base f?
- 0 base \ f type-number CMPI
- "not-f" get BNE
-
- ! Yes, it is f. Fill in new object
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- displacement dst 4 alien@ STW
-
- "end" get B
-
- "not-f" resolve-label
-
- ! Check base type
- temp base tag-mask get ANDI
-
- ! Is base an alien?
- 0 temp alien type-number CMPI
- "not-alien" get BNE
-
- ! Yes, it is an alien. Set new alien's base to base.base
- temp base 1 alien@ LWZ
- temp dst 1 alien@ STW
-
- ! Compute displacement
- temp base 3 alien@ LWZ
- temp temp displacement ADD
- temp dst 3 alien@ STW
-
- ! Compute address
- temp base 4 alien@ LWZ
- temp temp displacement ADD
- temp dst 4 alien@ STW
-
- ! We are done
- "end" get B
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- temp base byte-array-offset ADDI
- temp temp displacement ADD
- temp dst 4 alien@ STW
+ dst displacement base temp
+ {
+ { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
+ { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
+ { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
+ [ %box-displaced-alien/dynamic ]
+ } cond
"end" resolve-label
] with-scope ;
-M: ppc %alien-unsigned-1 LBZ ;
-M: ppc %alien-unsigned-2 LHZ ;
-
-M: ppc %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ;
-M: ppc %alien-signed-2 LHA ;
-
-M: ppc %alien-cell LWZ ;
+M: ppc %load-memory-imm ( dst base offset rep c-type -- )
+ [
+ {
+ { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
+ { c:uchar [ LBZ ] }
+ { c:short [ LHA ] }
+ { c:ushort [ LHZ ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZ ] }
+ { float-rep [ LFS ] }
+ { double-rep [ LFD ] }
+ } case
+ ] ?if ;
-M: ppc %alien-float LFS ;
-M: ppc %alien-double LFD ;
+: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
+ [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
-M: ppc %set-alien-integer-1 -rot STB ;
-M: ppc %set-alien-integer-2 -rot STH ;
+M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
+ (%memory) [
+ {
+ { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
+ { c:uchar [ LBZX ] }
+ { c:short [ LHAX ] }
+ { c:ushort [ LHZX ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZX ] }
+ { float-rep [ LFSX ] }
+ { double-rep [ LFDX ] }
+ } case
+ ] ?if ;
-M: ppc %set-alien-cell -rot STW ;
+M: ppc %store-memory-imm ( src base offset rep c-type -- )
+ [
+ {
+ { c:char [ STB ] }
+ { c:uchar [ STB ] }
+ { c:short [ STH ] }
+ { c:ushort [ STH ] }
+ } case
+ ] [
+ {
+ { int-rep [ STW ] }
+ { float-rep [ STFS ] }
+ { double-rep [ STFD ] }
+ } case
+ ] ?if ;
-M: ppc %set-alien-float -rot STFS ;
-M: ppc %set-alien-double -rot STFD ;
+M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
+ (%memory) [
+ {
+ { c:char [ STBX ] }
+ { c:uchar [ STBX ] }
+ { c:short [ STHX ] }
+ { c:ushort [ STHX ] }
+ } case
+ ] [
+ {
+ { int-rep [ STWX ] }
+ { float-rep [ STFSX ] }
+ { double-rep [ STFDX ] }
+ } case
+ ] ?if ;
: load-zone-ptr ( reg -- )
vm-reg "nursery" vm-field-offset ADDI ;
temp2 load-decks-offset
temp1 scratch-reg temp2 STBX ;
-M:: ppc %write-barrier ( src slot temp1 temp2 -- )
+M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
+ scale 0 assert= tag 0 assert=
temp1 src slot ADD
temp1 temp2 (%write-barrier) ;
-M:: ppc %write-barrier-imm ( src slot temp1 temp2 -- )
- temp1 src slot ADDI
+M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
+ temp1 src slot tag slot-offset ADDI
temp1 temp2 (%write-barrier) ;
-M:: ppc %check-nursery ( label size temp1 temp2 -- )
- temp2 load-zone-ptr
- temp1 temp2 0 LWZ
- temp2 temp2 2 cells LWZ
+M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
+ temp1 vm-reg "nursery" vm-field-offset LWZ
+ temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
temp1 temp1 size ADDI
! is here >= end?
temp1 0 temp2 CMP
- label BLE ;
-
-M:: ppc %save-gc-root ( gc-root register -- )
- register 1 gc-root gc-root@ STW ;
+ cc {
+ { cc<= [ label BLE ] }
+ { cc/<= [ label BGT ] }
+ } case ;
-M:: ppc %load-gc-root ( gc-root register -- )
- register 1 gc-root gc-root@ LWZ ;
+: gc-root-offsets ( seq -- seq' )
+ [ n>> spill@ ] map f like ;
-M:: ppc %call-gc ( gc-root-count temp -- )
- 3 1 gc-root-base local@ ADDI
- gc-root-count 4 LI
- 5 %load-vm-addr
+M: ppc %call-gc ( gc-roots -- )
+ 3 swap gc-root-offsets %load-reference
+ 4 %load-vm-addr
"inline_gc" f %alien-invoke ;
M: ppc %prologue ( n -- )
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-: (%compare-imm) ( src1 src2 -- ) [ 0 ] [ ] [ \ f type-number or ] tri* CMPI ; inline
-: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
-: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+
+: (%compare-integer-imm) ( src1 src2 -- )
+ [ 0 ] 2dip CMPI ; inline
+
+: (%compare-imm) ( src1 src2 -- )
+ [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
+
+: (%compare-float-unordered) ( src1 src2 -- )
+ [ 0 ] dip FCMPU ; inline
+
+: (%compare-float-ordered) ( src1 src2 -- )
+ [ 0 ] dip FCMPO ; inline
:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
cc {
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
+
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
src1 src2 (%compare-imm)
label cc %branch ;
+M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-integer-imm)
+ label cc %branch ;
+
:: (%branch) ( label branch1 branch2 -- )
label branch1 execute( label -- )
branch2 [ label branch2 execute( label -- ) ] when ; inline
: load-from-frame ( dst n rep -- )
{
{ int-rep [ [ 1 ] dip LWZ ] }
+ { tagged-rep [ [ 1 ] dip LWZ ] }
{ float-rep [ [ 1 ] dip LFS ] }
{ double-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
+ { tagged-rep [ [ 1 ] dip STW ] }
{ float-rep [ [ 1 ] dip STFS ] }
{ double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
+
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
+
M: float-regs return-reg drop 1 ;
M:: ppc %save-param-reg ( stack reg rep -- )
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
+M: ppc immediate-store? drop f ;
+
M: ppc struct-return-pointer-type void* ;
M: ppc return-struct-in-registers? ( c-type -- ? )
vocabs.loader accessors init classes.struct combinators
command-line make words compiler compiler.units
compiler.constants compiler.alien compiler.codegen
-compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics
-compiler.cfg.stack-frame cpu.x86.assembler
-cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
+compiler.codegen.alien compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.architecture vm ;
FROM: layouts => cell ;
IN: cpu.x86.32
M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
-M: x86.32 immediate-comparand? ( n -- ? )
- [ call-next-method ] [ word? ] bi or ;
-
-M: x86.32 load-double? ( -- ? ) t ;
+M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M: x86.32 %load-double ( dst val -- )
- [ 0 [] MOVSD ] dip rc-absolute rel-float ;
+ [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
+
+M:: x86.32 %load-vector ( dst val rep -- )
+ dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
- cell code-alignment
+ cell alignment
[ end start - + building get dup pop* push ]
- [ align-code ]
+ [ (align-code) ]
bi ;
M: x86.32 pic-tail-reg EDX ;
M: x86.32 %cleanup ( params -- )
stack-cleanup [ ESP swap SUB ] unless-zero ;
-M:: x86.32 %call-gc ( gc-root-count temp -- )
- temp gc-root-base special@ LEA
- 8 save-vm-ptr
- 4 stack@ gc-root-count MOV
- 0 stack@ temp MOV
+M:: x86.32 %call-gc ( gc-roots -- )
+ 4 save-vm-ptr
+ 0 stack@ gc-roots gc-root-offsets %load-reference
"inline_gc" f %alien-invoke ;
M: x86.32 dummy-stack-params? f ;
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.libraries
slots splitting assocs combinators locals compiler.constants
-compiler.codegen compiler.codegen.fixup
+compiler.codegen compiler.codegen.alien compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
+M: x86.64 %load-double ( dst val -- )
+ [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
+
+M:: x86.64 %load-vector ( dst val rep -- )
+ dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
+
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
- cell code-alignment
+ cell alignment
[ end start - + building get dup pop* push ]
- [ align-code ]
+ [ (align-code) ]
bi ;
M: stack-params copy-register*
] [
rep load-return-value
] if
- rep int-rep?
- cpu x86.64? os windows? and or
- param-reg-1 param-reg-0 ? %mov-vm-ptr
+ rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke ;
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
func "libm" load-library %alien-invoke
dst float-function-return ;
-M:: x86.64 %call-gc ( gc-root-count temp -- )
- ! Pass pointer to start of GC roots as first parameter
- param-reg-0 gc-root-base param@ LEA
- ! Pass number of roots as second parameter
- param-reg-1 gc-root-count MOV
- ! Pass VM ptr as third parameter
- param-reg-2 %mov-vm-ptr
- ! Call GC
+M:: x86.64 %call-gc ( gc-roots -- )
+ param-reg-0 gc-roots gc-root-offsets %load-reference
+ param-reg-1 %mov-vm-ptr
"inline_gc" f %alien-invoke ;
M: x86.64 struct-return-pointer-type void* ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types classes.struct cpu.architecture
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
-compiler.cfg.registers ;
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types classes.struct
+cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
+cpu.x86 compiler.codegen.alien compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs
kernel tools.test namespaces make layouts ;
IN: cpu.x86.assembler.tests
+! immediate operands
+cell 4 = [
+ [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+] [
+ [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+] if
+
+[ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
+[ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+
+! 64-bit registers
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
+! memory address modes
+[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 88 HEX: 18 } ] [ [ RAX [] BL MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 18 } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
+
+[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
+[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
+[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { HEX: 89 HEX: 1c HEX: 11 } ] [ [ ECX EDX [+] EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 51 } ] [ [ ECX EDX 1 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 91 } ] [ [ ECX EDX 2 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: d1 } ] [ [ ECX EDX 3 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ ECX EDX 0 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ ECX EDX 1 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ ECX EDX 2 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ ECX EDX 3 100 <indirect> EBX MOV ] { } make ] unit-test
+
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 11 } ] [ [ RCX RDX [+] RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 51 } ] [ [ RCX RDX 1 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 91 } ] [ [ RCX RDX 2 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: d1 } ] [ [ RCX RDX 3 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ RCX RDX 0 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ RCX RDX 1 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ RCX RDX 2 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ RCX RDX 3 100 <indirect> RBX MOV ] { } make ] unit-test
+
! r-rm / m-r sse instruction
[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test
[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2a HEX: c0 } ] [ [ XMM0 RAX CVTSI2SD ] { } make ] unit-test
[ { HEX: f2 HEX: 49 HEX: 0f HEX: 2a HEX: c4 } ] [ [ XMM0 R12 CVTSI2SD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2c HEX: c1 } ] [ [ XMM9 RAX CVTSI2SD ] { } make ] unit-test
-
-! [ { HEX: f2 HEX: 0f HEX: 10 HEX: 00 } ] [ [ XMM0 RAX [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 10 HEX: 04 HEX: 24 } ] [ [ XMM0 R12 [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
-
! 3-operand r-rm-imm sse instructions
[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
[ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
-! memory address modes
-[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 88 HEX: 18 } ] [ [ RAX [] BL MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
-[ { HEX: 89 HEX: 18 } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
-
-[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
-[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
-
-[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
-[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
-[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
-
+! shifts
[ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
-[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+[ { HEX: c1 HEX: e0 HEX: 05 } ] [ [ EAX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e1 HEX: 05 } ] [ [ ECX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e8 HEX: 05 } ] [ [ EAX 5 SHR ] { } make ] unit-test
+[ { HEX: c1 HEX: e9 HEX: 05 } ] [ [ ECX 5 SHR ] { } make ] unit-test
+! multiplication
[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
combinators.short-circuit math math.bitwise locals namespaces
make sequences words system layouts math.order accessors
cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
-QUALIFIED: sequences
IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64.
: 2, ( n -- ) 2 n, ; inline
: cell, ( n -- ) bootstrap-cell n, ; inline
-: mod-r/m, ( reg# indirect -- )
+: mod-r/m, ( reg operand -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
-: sib, ( indirect -- )
+: sib, ( operand -- )
dup sib-present? [
[ indirect-base* ]
[ indirect-index* 3 shift ]
M: register displacement, drop ;
-: addressing ( reg# indirect -- )
+: addressing ( reg operand -- )
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
: rex.w? ( rex.w reg r/m -- ? )
{
- { [ dup register-128? ] [ drop operand-64? ] }
- { [ dup not ] [ drop operand-64? ] }
- [ nip operand-64? ]
+ { [ over register-128? ] [ nip operand-64? ] }
+ { [ over not ] [ nip operand-64? ] }
+ [ drop operand-64? ]
} cond and ;
: rex.r ( m op -- n )
:: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix.
rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
- r/m rex.r
- reg rex.b
+ reg rex.r
+ r/m rex.b
dup reg r/m no-prefix? [ drop ] [ , ] if ;
-: 16-prefix ( reg r/m -- )
- [ register-16? ] either? [ HEX: 66 , ] when ;
+: 16-prefix ( reg -- )
+ register-16? [ HEX: 66 , ] when ;
-: prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
+: prefix-1 ( reg rex.w -- )
+ [ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' )
- dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
+ dup array? [ OCT: 17 prefix ] [ OCT: 17 swap 2array ] if ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
: opcode-or ( opcode mask -- opcode' )
- swap dup array?
- [ unclip-last rot bitor suffix ] [ bitor ] if ;
+ over array?
+ [ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
-: 1-operand ( op reg,rex.w,opcode -- )
+: 1-operand ( operand reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
-: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
- pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
+: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ over integer? [ first3 BIN: 1 opcode-or 3array ] when ;
-: immediate-1 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 1, ;
+: immediate-1 ( dst imm reg,rex.w,opcode -- )
+ immediate-operand-size-bit swap [ 1-operand ] dip 1, ;
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
- immediate-operand-size-bit 1-operand 4, ;
+: immediate-4 ( dst imm reg,rex.w,opcode -- )
+ immediate-operand-size-bit swap [ 1-operand ] dip 4, ;
-: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
- pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+: immediate-fits-in-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ over integer? [ first3 BIN: 10 opcode-or 3array ] when ;
-: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
+: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
#! If imm is a byte, compile the opcode and the byte.
#! Otherwise, set the 8-bit operand flag in the opcode, and
#! compile the cell. The 'reg' is not really a register, but
#! a value for the 'reg' field of the mod-r/m byte.
- pick fits-in-byte? [
+ over fits-in-byte? [
immediate-fits-in-size-bit immediate-1
] [
immediate-4
] if ;
-: (2-operand) ( dst src op -- )
+: (2-operand) ( reg operand op -- )
[ 2dup t rex-prefix ] dip opcode,
- reg-code swap addressing ;
+ [ reg-code ] dip addressing ;
-: direction-bit ( dst src op -- dst' src' op' )
+: direction-bit ( dst src op -- reg operand op' )
pick register? pick register? not and
- [ BIN: 10 opcode-or swapd ] when ;
+ [ BIN: 10 opcode-or ] [ swapd ] if ;
-: operand-size-bit ( dst src op -- dst' src' op' )
- over register-8? [ BIN: 1 opcode-or ] unless ;
+: operand-size-bit ( reg operand op -- reg operand op' )
+ pick register-8? [ BIN: 1 opcode-or ] unless ;
: 2-operand ( dst src op -- )
- #! Sets the opcode's direction bit. It is set if the
- #! destination is a direct register operand.
- [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
+ direction-bit operand-size-bit
+ pick 16-prefix
+ (2-operand) ;
PRIVATE>
! MOV where the src is immediate.
<PRIVATE
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
+GENERIC# (MOV-I) 1 ( dst src -- )
+M: register (MOV-I) [ t HEX: b8 short-operand ] [ cell, ] bi* ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
- pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+ over byte? [ immediate-1 ] [ immediate-4 ] if ;
PRIVATE>
GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
+M: immediate MOV (MOV-I) ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
! Arithmetic
GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
+M: immediate ADD { BIN: 000 t HEX: 80 } immediate-1/4 ;
M: operand ADD OCT: 000 2-operand ;
GENERIC: OR ( dst src -- )
-M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
+M: immediate OR { BIN: 001 t HEX: 80 } immediate-1/4 ;
M: operand OR OCT: 010 2-operand ;
GENERIC: ADC ( dst src -- )
-M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
+M: immediate ADC { BIN: 010 t HEX: 80 } immediate-1/4 ;
M: operand ADC OCT: 020 2-operand ;
GENERIC: SBB ( dst src -- )
-M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
+M: immediate SBB { BIN: 011 t HEX: 80 } immediate-1/4 ;
M: operand SBB OCT: 030 2-operand ;
GENERIC: AND ( dst src -- )
-M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
+M: immediate AND { BIN: 100 t HEX: 80 } immediate-1/4 ;
M: operand AND OCT: 040 2-operand ;
GENERIC: SUB ( dst src -- )
-M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
+M: immediate SUB { BIN: 101 t HEX: 80 } immediate-1/4 ;
M: operand SUB OCT: 050 2-operand ;
GENERIC: XOR ( dst src -- )
-M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
+M: immediate XOR { BIN: 110 t HEX: 80 } immediate-1/4 ;
M: operand XOR OCT: 060 2-operand ;
GENERIC: CMP ( dst src -- )
-M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
+M: immediate CMP { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
GENERIC: TEST ( dst src -- )
-M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: immediate TEST { BIN: 0 t HEX: f7 } immediate-4 ;
M: operand TEST OCT: 204 2-operand ;
: XCHG ( dst src -- ) OCT: 207 2-operand ;
-: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+: BSR ( dst src -- ) { HEX: 0f HEX: bd } (2-operand) ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
<PRIVATE
-: (SHIFT) ( dst src op -- )
- over CL eq? [
- nip t HEX: d3 3array 1-operand
+:: (SHIFT) ( dst src op -- )
+ src CL eq? [
+ dst { op t HEX: d3 } 1-operand
] [
- swapd t HEX: c0 3array immediate-1
+ dst src { op t HEX: c0 } immediate-1
] if ; inline
PRIVATE>
] if ;
: MOVSX ( dst src -- )
- swap
- over register-32? OCT: 143 OCT: 276 extended-opcode ?
- pick register-16? [ BIN: 1 opcode-or ] when
+ dup register-32? OCT: 143 OCT: 276 extended-opcode ?
+ over register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
: MOVZX ( dst src -- )
- swap
OCT: 266 extended-opcode
- pick register-16? [ BIN: 1 opcode-or ] when
+ over register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
+: MOVcc ( dst src cc -- ) extended-opcode (2-operand) ;
: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
<PRIVATE
: direction-bit-sse ( dst src op1 -- dst' src' op1' )
- pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
+ pick register-128? [ swapd BIN: 1 bitor ] unless ;
: 2-operand-sse ( dst src op1 op2 -- )
[ , ] when* direction-bit-sse extended-opcode (2-operand) ;
: direction-op-sse ( dst src op1s -- dst' src' op1' )
- pick register-128? [ swapd first ] [ second ] if ;
+ pick register-128? [ first ] [ swapd second ] if ;
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
: 2-operand-rm-sse ( dst src op1 op2 -- )
- [ , ] when* swapd extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode (2-operand) ;
: 2-operand-mr-sse ( dst src op1 op2 -- )
- [ , ] when* extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode swapd (2-operand) ;
: 2-operand-int/sse ( dst src op1 op2 -- )
- [ , ] when* swapd extended-opcode (2-operand) ;
+ [ , ] when* extended-opcode (2-operand) ;
-: 3-operand-rm-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-rm-sse ] dip , ;
+:: 3-operand-rm-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-rm-sse imm , ;
-: 3-operand-mr-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-mr-sse ] dip , ;
+:: 3-operand-mr-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-mr-sse imm , ;
-: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
- rot [ 2-operand-rm-mr-sse ] dip , ;
+:: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
+ dst src op1 op2 2-operand-rm-mr-sse imm , ;
: 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
3-operand-rm-sse ; inline
: CMPNLESS ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ;
: CMPORDSS ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ;
-: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
+: MOVNTI ( dest src -- ) swap { HEX: 0f HEX: c3 } (2-operand) ;
: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
: SHUFPS ( dest src imm -- ) 4shuffler HEX: c6 f 3-operand-rm-sse ;
: HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken
: HST ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken
-
M: indirect extended? base>> extended? ;
+: canonicalize-displacement ( indirect -- indirect )
+ dup [ base>> ] [ displacement>> 0 = ] bi and
+ [ f >>displacement ] when ;
+
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- canonicalize-EBP check-ESP ;
-
-: <indirect> ( base index scale displacement -- indirect )
- indirect boa canonicalize ;
+ canonicalize-displacement canonicalize-EBP check-ESP ;
! Utilities
UNION: operand register indirect ;
PRIVATE>
-: [] ( reg/displacement -- indirect )
+: <indirect> ( base index scale displacement -- indirect )
+ indirect boa canonicalize ;
+
+: [] ( base/displacement -- indirect )
dup integer?
[ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
[ f f f <indirect> ]
: [RIP+] ( displacement -- indirect )
[ f f f ] dip <indirect> ;
-: [+] ( reg displacement -- indirect )
+: [+] ( base index/displacement -- indirect )
dup integer?
- [ dup zero? [ drop f ] when [ f f ] dip ]
+ [ [ f f ] dip ]
[ f f ] if
<indirect> ;
+: [++] ( base index displacement -- indirect )
+ [ f ] dip <indirect> ;
+
+: [+*2+] ( base index displacement -- indirect )
+ [ 1 ] dip <indirect> ;
+
+: [+*4+] ( base index displacement -- indirect )
+ [ 2 ] dip <indirect> ;
+
+: [+*8+] ( base index displacement -- indirect )
+ [ 3 ] dip <indirect> ;
+
TUPLE: byte value ;
C: <byte> byte
USING: bootstrap.image.private compiler.constants
compiler.units cpu.x86.assembler cpu.x86.assembler.operands
kernel kernel.private layouts locals.backend make math
-math.private namespaces sequences slots.private vocabs ;
+math.private namespaces sequences slots.private strings.private
+vocabs ;
IN: bootstrap.x86
big-endian off
ds-reg [] temp0 MOV
] \ slot define-sub-primitive
+[
+ ! load string index from stack
+ temp0 ds-reg bootstrap-cell neg [+] MOV
+ temp0 tag-bits get SHR
+ ! load string from stack
+ temp1 ds-reg [] MOV
+ ! load character
+ temp0 8-bit-version-of temp0 temp1 string-offset [++] MOV
+ temp0 temp0 8-bit-version-of MOVZX
+ temp0 tag-bits get SHL
+ ! store character to stack
+ ds-reg bootstrap-cell SUB
+ ds-reg [] temp0 MOV
+] \ string-nth-fast define-sub-primitive
+
! Shufflers
[
ds-reg bootstrap-cell SUB
! multiply
temp0 temp1 IMUL2
! push result
- ds-reg [] temp1 MOV
+ ds-reg [] temp0 MOV
] \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
cpu.x86.features cpu.x86.features.private cpu.architecture kernel
kernel.private math memory namespaces make sequences words system
layouts combinators math.order math.vectors fry locals compiler.constants
-byte-arrays io macros quotations compiler compiler.units init vm
+byte-arrays io macros quotations classes.algebra compiler
+compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.codegen.fixup ;
+QUALIFIED-WITH: alien.c-types c
FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.x86
: stack@ ( n -- op ) stack-reg swap [+] ;
-: special@ ( n -- op )
+: special-offset ( m -- n )
stack-frame get extra-stack-space +
- reserved-stack-space +
- stack@ ;
+ reserved-stack-space + ;
-: spill@ ( n -- op ) spill-offset special@ ;
+: special@ ( n -- op ) special-offset stack@ ;
-: gc-root@ ( n -- op ) gc-root-offset special@ ;
+: spill@ ( n -- op ) spill-offset special@ ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
+: gc-root-offsets ( seq -- seq' )
+ [ n>> spill-offset special-offset cell + ] map f like ;
+
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
HOOK: pic-tail-reg cpu ( -- reg )
+M: x86 complex-addressing? t ;
+
+M: x86 fused-unboxing? t ;
+
+M: x86 immediate-store? immediate-comparand? ;
+
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-literal ;
+M: x86 %load-reference
+ [ swap 0 MOV rc-absolute-cell rel-literal ]
+ [ \ f type-number MOV ]
+ if* ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
M: rs-loc loc>operand n>> rs-reg reg-stack ;
M: x86 %peek loc>operand MOV ;
+
M: x86 %replace loc>operand swap MOV ;
+
+M: x86 %replace-imm
+ loc>operand swap
+ {
+ { [ dup not ] [ drop \ f type-number MOV ] }
+ { [ dup fixnum? ] [ tag-fixnum MOV ] }
+ [ [ HEX: ffffffff MOV ] dip rc-absolute rel-literal ]
+ } cond ;
+
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86 %return ( -- ) 0 RET ;
-: code-alignment ( align -- n )
- [ building get length dup ] dip align swap - ;
-
-: align-code ( n -- )
- 0 <repetition> % ;
+: (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
+: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
-:: (%slot-imm) ( obj slot tag -- op )
- obj slot tag slot-offset [+] ; inline
-
-M: x86 %slot ( dst obj slot -- ) [+] MOV ;
+M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
-M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
+M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
:: two-operand ( dst src1 src2 rep -- dst src )
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul int-rep two-operand swap IMUL2 ;
+M: x86 %mul int-rep two-operand IMUL2 ;
M: x86 %mul-imm IMUL3 ;
M: x86 %and int-rep two-operand AND ;
M: x86 %and-imm int-rep two-operand AND ;
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
-M: x86 %fixnum-add ( label dst src1 src2 -- )
- int-rep two-operand ADD JO ;
+: fixnum-overflow ( label dst src1 src2 cc quot -- )
+ swap [ [ int-rep two-operand ] dip call ] dip
+ {
+ { cc-o [ JO ] }
+ { cc/o [ JNO ] }
+ } case ; inline
+
+M: x86 %fixnum-add ( label dst src1 src2 cc -- )
+ [ ADD ] fixnum-overflow ;
-M: x86 %fixnum-sub ( label dst src1 src2 -- )
- int-rep two-operand SUB JO ;
+M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
+ [ SUB ] fixnum-overflow ;
-M: x86 %fixnum-mul ( label dst src1 src2 -- )
- int-rep two-operand swap IMUL2 JO ;
+M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
+ [ IMUL2 ] fixnum-overflow ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
"end" resolve-label
] with-scope ;
+:: %box-displaced-alien/f ( dst displacement -- )
+ dst 1 alien@ \ f type-number MOV
+ dst 3 alien@ displacement MOV
+ dst 4 alien@ displacement MOV ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+ ! Set new alien's base to base.base
+ temp base 1 alien@ MOV
+ dst 1 alien@ temp MOV
+
+ ! Compute displacement
+ temp base 3 alien@ MOV
+ temp displacement ADD
+ dst 3 alien@ temp MOV
+
+ ! Compute address
+ temp base 4 alien@ MOV
+ temp displacement ADD
+ dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ temp base displacement byte-array-offset [++] LEA
+ dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
+ "not-f" define-label
+ "not-alien" define-label
+
+ ! Check base type
+ temp base MOV
+ temp tag-mask get AND
+
+ ! Is base f?
+ temp \ f type-number CMP
+ "not-f" get JNE
+
+ ! Yes, it is f. Fill in new object
+ dst displacement %box-displaced-alien/f
+
+ "end" get JMP
+
+ "not-f" resolve-label
+
+ ! Is base an alien?
+ temp alien type-number CMP
+ "not-alien" get JNE
+
+ dst displacement base temp %box-displaced-alien/alien
+
+ ! We are done
+ "end" get JMP
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst displacement base temp %box-displaced-alien/byte-array ;
+
M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
- ! This is ridiculous
[
"end" define-label
- "not-f" define-label
- "not-alien" define-label
! If displacement is zero, return the base
dst base MOV
! Set expired to f
dst 2 alien@ \ f type-number MOV
- ! Is base f?
- base \ f type-number CMP
- "not-f" get JNE
-
- ! Yes, it is f. Fill in new object
- dst 1 alien@ base MOV
- dst 3 alien@ displacement MOV
- dst 4 alien@ displacement MOV
-
- "end" get JMP
-
- "not-f" resolve-label
-
- ! Check base type
- temp base MOV
- temp tag-mask get AND
-
- ! Is base an alien?
- temp alien type-number CMP
- "not-alien" get JNE
-
- ! Yes, it is an alien. Set new alien's base to base.base
- temp base 1 alien@ MOV
- dst 1 alien@ temp MOV
-
- ! Compute displacement
- temp base 3 alien@ MOV
- temp displacement ADD
- dst 3 alien@ temp MOV
-
- ! Compute address
- temp base 4 alien@ MOV
- temp displacement ADD
- dst 4 alien@ temp MOV
-
- ! We are done
- "end" get JMP
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- dst 1 alien@ base MOV
- dst 3 alien@ displacement MOV
- temp base MOV
- temp byte-array-offset ADD
- temp displacement ADD
- dst 4 alien@ temp MOV
+ dst displacement base temp
+ {
+ { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
+ { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
+ { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
+ [ %box-displaced-alien/dynamic ]
+ } cond
"end" resolve-label
] with-scope ;
[ quot call ] with-save/restore
] 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.
- "end" define-label
- dst { src index temp } 8 [| new-dst |
- ! Load the least significant 7 bits into new-dst.
- ! 8th bit indicates whether we have to load from
- ! the aux vector or not.
- temp src index [+] LEA
- new-dst 8-bit-version-of temp string-offset [+] MOV
- new-dst new-dst 8-bit-version-of MOVZX
- ! Do we have to look at the aux vector?
- new-dst HEX: 80 CMP
- "end" get JL
- ! Yes, this is a non-ASCII character. Load aux vector
- temp src string-aux-offset [+] MOV
- new-dst temp XCHG
- ! Compute index
- new-dst index ADD
- new-dst index ADD
- ! Load high 16 bits
- new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
- new-dst new-dst 16-bit-version-of MOVZX
- new-dst 7 SHL
- ! Compute code point
- new-dst temp XOR
- "end" resolve-label
- dst new-dst int-rep %copy
- ] with-small-register ;
-
-M:: x86 %set-string-nth-fast ( ch str index temp -- )
- ch { index str temp } 8 [| new-ch |
- new-ch ch int-rep %copy
- temp str index [+] LEA
- temp string-offset [+] new-ch 8-bit-version-of MOV
- ] with-small-register ;
-
-:: %alien-integer-getter ( dst src offset size quot -- )
- dst { src } size [| new-dst |
- new-dst dup size n-bit-version-of dup src offset [+] MOV
+:: %alien-integer-getter ( dst exclude address bits quot -- )
+ dst exclude bits [| new-dst |
+ new-dst dup bits n-bit-version-of dup address MOV
quot call
dst new-dst int-rep %copy
] with-small-register ; inline
-: %alien-unsigned-getter ( dst src offset size -- )
+: %alien-unsigned-getter ( dst exclude address bits -- )
[ MOVZX ] %alien-integer-getter ; inline
-: %alien-signed-getter ( dst src offset size -- )
+: %alien-signed-getter ( dst exclude address bits -- )
[ MOVSX ] %alien-integer-getter ; inline
-:: %alien-integer-setter ( ptr offset value size -- )
- value { ptr } size [| new-value |
+:: %alien-integer-setter ( value exclude address bits -- )
+ value exclude bits [| new-value |
new-value value int-rep %copy
- ptr offset [+] new-value size n-bit-version-of MOV
+ address new-value bits n-bit-version-of MOV
] with-small-register ; inline
-M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
+: (%memory) ( base displacement scale offset rep c-type -- exclude address rep c-type )
+ [ [ [ 2array ] 2keep ] 2dip <indirect> ] 2dip ;
-M: x86 %alien-signed-1 8 %alien-signed-getter ;
-M: x86 %alien-signed-2 16 %alien-signed-getter ;
-M: x86 %alien-signed-4 32 %alien-signed-getter ;
+: (%memory-imm) ( base offset rep c-type -- exclude address rep c-type )
+ [ [ drop 1array ] [ [+] ] 2bi ] 2dip ;
-M: x86 %alien-cell [+] MOV ;
-M: x86 %alien-float [+] MOVSS ;
-M: x86 %alien-double [+] MOVSD ;
-M: x86 %alien-vector [ [+] ] dip %copy ;
+: (%load-memory) ( dst exclude address rep c-type -- )
+ [
+ {
+ { c:char [ 8 %alien-signed-getter ] }
+ { c:uchar [ 8 %alien-unsigned-getter ] }
+ { c:short [ 16 %alien-signed-getter ] }
+ { c:ushort [ 16 %alien-unsigned-getter ] }
+ { c:int [ 32 %alien-signed-getter ] }
+ { c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
+ } case
+ ] [ [ drop ] 2dip %copy ] ?if ;
-M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
-M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
-M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [+] ] dip MOV ;
-M: x86 %set-alien-float [ [+] ] dip MOVSS ;
-M: x86 %set-alien-double [ [+] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
+M: x86 %load-memory ( dst base displacement scale offset rep c-type -- )
+ (%memory) (%load-memory) ;
+
+M: x86 %load-memory-imm ( dst base offset rep c-type -- )
+ (%memory-imm) (%load-memory) ;
+
+: (%store-memory) ( src exclude address rep c-type -- )
+ [
+ {
+ { c:char [ 8 %alien-integer-setter ] }
+ { c:uchar [ 8 %alien-integer-setter ] }
+ { c:short [ 16 %alien-integer-setter ] }
+ { c:ushort [ 16 %alien-integer-setter ] }
+ { c:int [ 32 %alien-integer-setter ] }
+ { c:uint [ 32 %alien-integer-setter ] }
+ } case
+ ] [ [ nip swap ] dip %copy ] ?if ;
+
+M: x86 %store-memory ( src base displacement scale offset rep c-type -- )
+ (%memory) (%store-memory) ;
+
+M: x86 %store-memory-imm ( src base offset rep c-type -- )
+ (%memory-imm) (%store-memory) ;
: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
HOOK: %mark-card cpu ( card temp -- )
HOOK: %mark-deck cpu ( card temp -- )
-:: (%write-barrier) ( src slot temp1 temp2 -- )
- temp1 src slot [+] LEA
+:: (%write-barrier) ( temp1 temp2 -- )
temp1 card-bits SHR
temp1 temp2 %mark-card
temp1 deck-bits card-bits - SHR
temp1 temp2 %mark-deck ;
-M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier ( src slot scale tag temp1 temp2 -- )
+ temp1 src slot scale tag (%slot) LEA
+ temp1 temp2 (%write-barrier) ;
-M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
+ temp1 src slot tag (%slot-imm) LEA
+ temp1 temp2 (%write-barrier) ;
-M:: x86 %check-nursery ( label size temp1 temp2 -- )
+M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
temp1 load-zone-offset
- ! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
- ! Load 'end' into temp1
- temp1 temp1 2 cells [+] MOV
- temp2 temp1 CMP
- label JLE ;
-
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
+ temp2 temp1 2 cells [+] CMP
+ cc {
+ { cc<= [ label JLE ] }
+ { cc/<= [ label JG ] }
+ } case ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
: (%compare-tagged) ( src1 src2 -- )
[ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
+: (%compare-integer-imm) ( src1 src2 cc -- )
+ 3dup use-test? [ 2drop dup TEST ] [ drop CMP ] if ;
+
+M:: x86 %compare-integer-imm ( dst src1 src2 cc temp -- )
+ src1 src2 cc (%compare-integer-imm)
+ dst cc temp %boolean ;
+
: (%compare-imm) ( src1 src2 cc -- )
{
- { [ 3dup use-test? ] [ 2drop dup TEST ] }
- { [ over integer? ] [ drop CMP ] }
- { [ over word? ] [ drop (%compare-tagged) ] }
+ { [ over fixnum? ] [ [ tag-fixnum ] dip (%compare-integer-imm) ] }
{ [ over not ] [ 2drop \ f type-number CMP ] }
+ [ drop (%compare-tagged) ]
} cond ;
M:: x86 %compare-imm ( dst src1 src2 cc temp -- )
src1 src2 CMP
label cc %branch ;
+M:: x86 %compare-integer-imm-branch ( label src1 src2 cc -- )
+ src1 src2 cc (%compare-integer-imm)
+ label cc %branch ;
+
M:: x86 %compare-imm-branch ( label src1 src2 cc -- )
src1 src2 cc (%compare-imm)
label cc %branch ;
M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
-M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
+M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
frame-reg swap 2 cells + [+] ;
enable-min/max
-enable-fixnum-log2
+enable-log2
:: install-sse2-check ( -- )
[
M: disjoint-set disjoint-set-member? parents>> key? ;
+GENERIC: disjoint-set-members ( disjoint-set -- seq )
+
+M: disjoint-set disjoint-set-members parents>> keys ;
+
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;
XINPUT_GAMEPAD_B
XINPUT_GAMEPAD_X
XINPUT_GAMEPAD_Y }
- [ [ bitand ] dip swap 0 = [ 2drop ] [ 1.0 -rot swap set-nth ] if ]
+ [ [ bitand ] dip swap 0 = [ 2drop ] [ [ 1.0 ] 2dip swap set-nth ] if ]
map-index-compose 2cleave ;
: >pov ( byte -- symbol )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii combinators images images.loader io
io.encodings.ascii io.encodings.string kernel locals make math
-math.parser prettyprint sequences ;
+math.parser sequences ;
IN: images.ppm
SINGLETON: ppm-image
compression.lzw endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
-math.bitwise math.order math.parser pack prettyprint sequences
+math.bitwise math.order math.parser pack sequences
strings math.vectors specialized-arrays locals
images.loader ;
FROM: alien.c-types => float ;
-USING: alien alien.c-types alien.data alien.syntax arrays continuations
-destructors generic io.mmap io.ports io.backend.windows io.files.windows
-kernel libc locals math math.bitwise namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 windows.types io.backend system accessors
-io.backend.windows.privileges classes.struct windows.errors literals ;
+USING: alien alien.c-types alien.data alien.syntax arrays
+continuations destructors generic io.mmap io.ports
+io.backend.windows io.files.windows kernel libc fry locals math
+math.bitwise namespaces quotations sequences windows
+windows.advapi32 windows.kernel32 windows.types io.backend
+system accessors io.backend.windows.privileges classes.struct
+windows.errors literals ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
>>Privileges ;
M: winnt set-privilege ( name ? -- )
- [
- -rot 0 -rot make-token-privileges
- dup byte-length f f AdjustTokenPrivileges win32-error=0/f
+ '[
+ 0
+ _ _ make-token-privileges
+ dup byte-length
+ f
+ f
+ AdjustTokenPrivileges win32-error=0/f
] with-process-token ;
] in-thread
p 1 seconds ?promise-timeout handle>> kill-process*
- s ?promise 0 =
+ s 3 seconds ?promise-timeout 0 =
]
] unit-test
: <empty-matrix> ( rows cols exemplar -- matrix )
[ element-type heap-size * * <byte-array> ]
[ 2drop ]
- [ f swap (blas-matrix-like) ] 3tri ;
+ [ [ f ] dip (blas-matrix-like) ] 3tri ;
: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
clone n*M.V+n*V! ;
n*M.V+n*V! ; inline
: M.V ( A x -- A.x )
- 1.0 -rot n*M.V ; inline
+ [ 1.0 ] 2dip n*M.V ; inline
: n*V(*)V ( alpha x y -- alpha*x(*)y )
2dup [ length>> ] bi@ pick <empty-matrix>
n*V(*)Vconj+M! ;
: V(*) ( x y -- x(*)y )
- 1.0 -rot n*V(*)V ; inline
+ [ 1.0 ] 2dip n*V(*)V ; inline
: V(*)conj ( x y -- x(*)yconj )
- 1.0 -rot n*V(*)Vconj ; inline
+ [ 1.0 ] 2dip n*V(*)Vconj ; inline
: n*M.M ( alpha A B -- alpha*A.B )
2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
- 1.0 swap n*M.M+n*M! ;
+ [ 1.0 ] dip n*M.M+n*M! ;
: M. ( A B -- A.B )
- 1.0 -rot n*M.M ; inline
+ [ 1.0 ] 2dip n*M.M ; inline
:: (Msub) ( matrix row col height width -- data ld rows cols )
matrix ld>> col * row + matrix element-type heap-size *
@
[ dup [ class ] { } map-as ] dip '[ _ declare @ ]
{
- [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+ [ "print-mr" get [ nip regs. ] [ 2drop ] if ]
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
[ [ [ call ] dip call ] call( quot quot -- result ) ]
[ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
+
+[
+ { "a" "a" }
+] [
+ EBNF: foo Bar = "a":a1 "a":a2 => [[ a1 a2 2array ]] ;EBNF
+ "aa" foo
+] unit-test
+
+[
+ { "a" "a" }
+] [
+ EBNF: foo2 Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF
+ "aa" foo2
+] unit-test
\r
: 'element' ( -- parser )\r
[\r
- [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
+ [\r
+ ('element') , ":" syntax ,\r
+ "a-zA-Z_" range-pattern\r
+ "a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action ,\r
+ ] seq* [ first2 <ebnf-var> ] action ,\r
('element') ,\r
] choice* ;\r
\r
[ ] [
[
struct-resize-test specialized-array-vocab forget-vocab
+ \ struct-resize-test-usage forget
] with-compilation-unit
] unit-test
\ set-slot { object object fixnum } { } define-primitive
\ set-special-object { object fixnum } { } define-primitive
\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
-\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
\ size { object } { fixnum } define-primitive \ size make-flushable
\ slot { object fixnum } { object } define-primitive \ slot make-flushable
\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
-\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable
+\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
\ strip-stack-traces { } { } define-primitive
\ system-micros { } { integer } define-primitive \ system-micros make-flushable
\ tag { object } { fixnum } define-primitive \ tag make-foldable
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files
-io.streams.c init fry namespaces math make assocs kernel parser
-parser.notes lexer strings.parser vocabs sequences sequences.deep
-sequences.private words memory kernel.private continuations io
-vocabs.loader system strings sets vectors quotations byte-arrays
-sorting compiler.units definitions generic generic.standard
-generic.single tools.deploy.config combinators classes vocabs.loader.private
-classes.builtin slots.private grouping command-line io.pathnames ;
+USING: arrays alien.libraries accessors io.backend
+io.encodings.utf8 io.files io.streams.c init fry namespaces math
+make assocs kernel parser parser.notes lexer strings.parser
+vocabs sequences sequences.deep sequences.private words memory
+kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units
+definitions generic generic.standard generic.single
+tools.deploy.config combinators combinators.private classes
+vocabs.loader.private classes.builtin slots.private grouping
+command-line io.pathnames ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes.private
QUALIFIED: compiler.crossref
strip-words
clear-megamorphic-caches ;
+: die-with ( error original-error -- * )
+ #! We don't want DCE to drop the error before the die call!
+ [ die 1 exit ] (( a -- * )) call-effect-unsafe ;
+
+: die-with2 ( error original-error -- * )
+ #! We don't want DCE to drop the error before the die call!
+ [ die 1 exit ] (( a b -- * )) call-effect-unsafe ;
+
: deploy-error-handler ( quot -- )
[
strip-debugger?
- [ error-continuation get call>> callstack>array die 1 exit ]
+ [ original-error get die-with2 ]
! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all
[ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
-USING: compiler.units words vocabs kernel threads.private ;
+USING: compiler.units continuations kernel namespaces
+threads.private words vocabs tools.deploy.shaker ;
IN: debugger
-: consume ( error -- )
- #! We don't want DCE to drop the error before the die call!
- drop ;
+: error. ( error -- ) original-error get die-with2 ;
-: print-error ( error -- ) die consume ;
-
-: error. ( error -- ) die consume ;
+: print-error ( error -- ) error. ;
"threads" vocab [
[
"error-in-thread" "threads" lookup
- [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
+ [ [ drop error. ] define ] [ f "combination" set-word-prop ] bi
] with-compilation-unit
] when
tools.disassembler words ;
IN: typed.debugger
-: typed-test-mr ( word -- mrs )
- "typed-word" word-prop test-mr ; inline
-: typed-test-mr. ( word -- )
- "typed-word" word-prop test-mr mr. ; inline
+M: typed-word test-builder
+ "typed-word" word-prop test-builder ;
+
: typed-optimized. ( word -- )
- "typed-word" word-prop optimized. ; inline
+ "typed-word" word-prop optimized. ;
-: typed-disassemble ( word -- )
- "typed-word" word-prop disassemble ; inline
+M: typed-word disassemble ( word -- )
+ "typed-word" word-prop disassemble ;
USE: vocabs.loader
{ "typed" "prettyprint" } "typed.prettyprint" require-when
+{ "typed" "compiler.cfg.debugger" } "typed.debugger" require-when
{ { $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:"
{ $subsections
- selected-rows
- (selected-rows)
- selected
+ selected-row
+ (selected-row)
} ;
ARTICLE: "ui.gadgets.tables.actions" "Table row actions"
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs hashtables arrays colors colors.constants fry
kernel math math.functions math.ranges math.rectangles math.order
GENERIC: row-columns ( row renderer -- columns )
GENERIC: row-value ( row renderer -- object )
GENERIC: row-color ( row renderer -- color )
+GENERIC: row-value? ( value row renderer -- ? )
SINGLETON: trivial-renderer
M: trivial-renderer row-columns drop ;
M: object row-value drop ;
M: object row-color 2drop f ;
+M: object row-value? drop eq? ;
TUPLE: table < line-gadget
{ renderer initial: trivial-renderer }
{ mouse-color initial: COLOR: black }
column-line-color
selection-required?
-selection
selection-index
-selected-indices
+selection
mouse-index
{ takes-focus? initial: t }
-focused?
-multiple-selection? ;
-
-<PRIVATE
-
-: add-selected-index ( table n -- table )
- over selected-indices>> 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 ;
+focused? ;
: new-table ( rows renderer class -- table )
new-line-gadget
focus-border-color >>focus-border-color
transparent >>column-line-color
f <model> >>selection-index
- f <model> >>selection
- H{ } clone >>selected-indices ;
+ f <model> >>selection ;
: <table> ( rows renderer -- table ) table new-table ;
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
-: draw-selected-rows ( table -- )
- {
- { [ dup selected-indices>> assoc-empty? ] [ drop ] }
- [
- [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
- [ swap row-bounds gl-fill-rect ] curry each
- ]
- } cond ;
+: draw-selected-row ( table -- )
+ dup selection-index>> value>> [
+ dup selection-color>> gl-color
+ dup selection-index>> value>> row-bounds gl-fill-rect
+ ] [ drop ] if ;
: draw-focused-row ( table -- )
- {
- { [ dup focused?>> not ] [ drop ] }
- { [ dup selected-index not ] [ drop ] }
- [
- [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
- row-bounds gl-rect
- ]
- } cond ;
+ dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
+ dup focus-border-color>> gl-color
+ dup selection-index>> value>> row-bounds gl-rect
+ ] [ drop ] if ;
: draw-moused-row ( table -- )
- dup mouse-index>> dup [
- over mouse-color>> gl-color
- row-bounds gl-rect
- ] [ 2drop ] if ;
+ dup mouse-index>> [
+ dup mouse-color>> gl-color
+ dup mouse-index>> row-bounds gl-rect
+ ] [ drop ] if ;
: column-line-offsets ( table -- xs )
[ column-widths>> ] [ gap>> ] bi
:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- ind table selected-indices>> key?
+ ind table selection-index>> value>> =
[ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-rows ]
+ [ draw-selected-row ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-rows) ( table -- assoc )
- [ selected-indices>> ] keep
- '[ _ nth-row drop ] assoc-map ;
-
-: 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 ? )
+ [ selection-index>> value>> ] keep nth-row ;
-: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
+: selected-row ( table -- value/f ? )
+ [ (selected-row) ] [ renderer>> ] bi
+ swap [ row-value t ] [ 2drop f f ] if ;
<PRIVATE
-: 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
[ swap [ renderer>> row-value ] keep show-summary ]
: hide-mouse-help ( table -- )
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
-: find-row-index ( value table -- n/f )
- [ model>> value>> ] [ renderer>> ] bi
- '[ _ row-value eq? ] with find drop ;
+: ((select-row)) ( n table -- )
+ [ selection-index>> set-model ]
+ [ [ selected-row drop ] keep selection>> set-model ]
+ bi ;
-: (update-selected-indices) ( table -- set )
- [ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep
- '[ _ find-row-index ] map sift unique f assoc-like ;
+: update-mouse-index ( table -- )
+ dup [ model>> value>> ] [ mouse-index>> ] bi
+ dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
+ >>mouse-index drop ;
-: initial-selected-indices ( table -- set )
+: initial-selection-index ( table -- n/f )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop { 0 } unique ]
+ [ drop 0 ]
} 1&& ;
-: update-selected-indices ( table -- set )
- {
- [ (update-selected-indices) ]
- [ initial-selected-indices ]
- } 1|| ;
+: find-row-index ( value table -- n/f )
+ [ model>> value>> ] [ renderer>> ] bi
+ '[ _ row-value? ] with find drop ;
+
+: update-selection ( table -- )
+ [
+ {
+ [ [ selection>> value>> ] keep find-row-index ]
+ [ initial-selection-index ]
+ } 1||
+ ] keep
+ over [ ((select-row)) ] [
+ [ selection-index>> set-model ]
+ [ selection>> set-model ]
+ 2bi
+ ] if ;
M: table model-changed
- nip dup update-selected-indices {
- [ >>selected-indices f >>mouse-index drop ]
- [ multiple>single drop show-row-summary ]
- [ drop update-selected ]
- [ drop relayout ]
- } 2cleave ;
+ nip
+ dup update-selection
+ dup update-mouse-index
+ [ dup mouse-index>> show-row-summary ] [ relayout ] bi ;
: 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 -- )
[ scroll-to-row ]
- [ set-selected-index relayout-1 ]
- 2bi ;
+ [ swap ((select-row)) ]
+ [ drop relayout-1 ]
+ 2tri ;
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
[ [ 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 -- )
- [ (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 ;
+ dup takes-focus?>> [ dup request-focus ] when
+ [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
PRIVATE>
: table-button-up ( table -- )
dup [ mouse-row ] keep valid-line? [
- dup row-action? [ row-action ] [ update-selected ] if
+ dup row-action? [ row-action ] [ drop ] if
] [ drop ] if ;
PRIVATE>
: select-row ( table n -- )
over validate-line
- [ (select-row) ]
- [ drop update-selected ]
- [ show-row-summary ]
- 2tri ;
+ [ (select-row) ] [ show-row-summary ] 2bi ;
<PRIVATE
: prev/next-row ( table n -- )
- [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
+ [ dup selection-index>> value>> ] dip
+ '[ _ + ] [ 0 ] if* select-row ;
: previous-row ( table -- )
-1 prev/next-row ;
{ mouse-enter show-mouse-help }
{ mouse-leave hide-mouse-help }
{ motion show-mouse-help }
- { 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 }
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sorting assocs colors.constants fry
combinators combinators.smart combinators.short-circuit editors make
M: source-file-renderer row-value
drop dup [ first [ <pathname> ] [ f ] if* ] when ;
+M: source-file-renderer row-value? row-value = ;
+
M: source-file-renderer column-titles
drop { "" "File" "Errors" } ;
[ swap '[ error-type _ at ] filter ] <smart-arrow> ;
:: <error-list-gadget> ( model -- gadget )
- vertical error-list-gadget new-track
+ vertical \ error-list-gadget new-track
<error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
dup visible-errors>> model <error-model> >>model
f <model> >>source-file
\ error-list-help H{ { +nullary+ t } } define-command
-error-list-gadget "toolbar" f {
+\ error-list-gadget "toolbar" f {
{ T{ key-down f f "F1" } error-list-help }
} define-command-map
-: error-list-window ( -- )
- error-list-model get [ drop all-errors ] <arrow>
- <error-list-gadget> "Errors" open-status-window ;
+MEMO: error-list-gadget ( -- gadget )
+ error-list-model get
-global [ drop all-errors ] <arrow>
+ <error-list-gadget> ;
: show-error-list ( -- )
- [ error-list-gadget? ] find-window
- [ raise-window ] [ error-list-window ] if* ;
+ [ error-list-gadget eq? ] find-window
+ [ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
\ show-error-list H{ { +nullary+ t } } define-command
-USING: windows.directx.dinput windows.kernel32 windows.ole32 windows.com
-windows.com.syntax alien alien.c-types alien.data alien.syntax
-kernel system namespaces combinators sequences fry math accessors
-macros words quotations libc continuations generalizations
-splitting locals assocs init specialized-arrays memoize
+USING: windows.directx.dinput windows.kernel32 windows.ole32
+windows.com windows.com.syntax alien alien.c-types alien.data
+alien.syntax kernel system namespaces combinators sequences fry
+math accessors macros words quotations libc continuations
+generalizations splitting locals assocs init specialized-arrays
classes.struct strings arrays literals ;
SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.directx.dinput.constants
<PRIVATE
-<<
+: initialize ( variable quot -- )
+ call swap set-global ; inline
-MEMO: c-type* ( name -- c-type ) c-type ;
-MEMO: heap-size* ( c-type -- n ) heap-size ;
+<<
GENERIC: array-base-type ( c-type -- c-type' )
M: object array-base-type ;
M: array array-base-type first ;
: (field-spec-of) ( field struct -- field-spec )
- c-type* fields>> [ name>> = ] with find nip ;
+ c-type fields>> [ name>> = ] with find nip ;
: (offsetof) ( field struct -- offset )
[ (field-spec-of) offset>> ] [ drop 0 ] if* ;
: (sizeof) ( field struct -- size )
- [ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ;
+ [ (field-spec-of) type>> array-base-type heap-size ] [ drop 1 ] if* ;
: (flag) ( thing -- integer )
{
[ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
} cleave
[ DIOBJECTDATAFORMAT <struct-boa> ] dip
- '[ _ clone @ >>pguid ] ;
+ curry ;
+
+: set-DIOBJECTDATAFORMAT ( array struct pguid n -- array )
+ [ [ clone ] dip >>pguid ] dip pick set-nth ;
:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
array [| args i |
struct args <DIOBJECTDATAFORMAT>-quot
- i '[ _ pick set-nth ] compose compose
- ] each-index ;
+ i '[ @ _ set-DIOBJECTDATAFORMAT ]
+ ] map-index [ ] join compose ;
>>
[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
: uninitialize ( variable quot -- )
- [ '[ _ when* f ] change-global ]
- [ drop global delete-at ] 2bi ; inline
+ [ [ get-global ] dip when* ] [ drop global delete-at ] 2bi ; inline
: free-dinput-constants ( -- )
{
unmaintained
build-support
images
+factor.dll.exp
+factor.dll.lib
+factor.exp
+factor.lib
+libfactor-ffi-test.exp
+libfactor-ffi-test.lib
[ 1 1 <displaced-alien> ] must-fail
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 1 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 2 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
-[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
+[ "( displaced alien )" ] [ 1 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
SYMBOL: initialize-test
{ "fixnum<=" "math.private" (( x y -- z )) }
{ "fixnum>" "math.private" (( x y -- ? )) }
{ "fixnum>=" "math.private" (( x y -- ? )) }
+ { "string-nth-fast" "strings.private" (( n string -- ch )) }
{ "(set-context)" "threads.private" (( obj context -- obj' )) }
{ "(set-context-and-delete)" "threads.private" (( obj context -- * )) }
{ "(start-context)" "threads.private" (( obj quot -- obj' )) }
{ "<string>" "strings" "primitive_string" (( n ch -- string )) }
{ "resize-string" "strings" "primitive_resize_string" (( n str -- newstr )) }
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
- { "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) }
- { "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) }
{ "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
{ "system-micros" "system" "primitive_system_micros" (( -- us )) }
swap [ set-datastack ] dip
] (( stack quot -- new-stack )) call-effect-unsafe ;
+SYMBOL: original-error
SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-thread
<PRIVATE
: save-error ( error -- )
- dup error set-global
- compute-restarts restarts set-global ;
+ [ error set-global ]
+ [ compute-restarts restarts set-global ] bi ;
PRIVATE>
dup save-error
catchstack* empty? [
thread-error-hook get-global
- [ (( error -- * )) call-effect-unsafe ] [ die ] if*
+ [ original-error get-global die ] or
+ (( error -- * )) call-effect-unsafe
] when
c> continue-with ;
! 63 = self
63 special-object error-thread set-global
continuation error-continuation set-global
- rethrow
+ [ original-error set-global ] [ rethrow ] bi
] 5 set-special-object
! VM adds this to kernel errors, so that user-space
! can identify them
"s" get >array
] unit-test
+! Make sure string initialization works
+[ HEX: 123456 ] [ 100 HEX: 123456 <string> first ] unit-test
+
! Make sure we clear aux vector when storing octets
[ "\u123456hi" ] [ "ih\u123456" clone reverse! ] unit-test
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.private sequences kernel.private
-math sequences.private slots.private alien.accessors ;
+USING: accessors alien.accessors byte-arrays kernel math.private
+sequences kernel.private math sequences.private slots.private ;
IN: strings
<PRIVATE
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
+: (aux) ( n string -- byte-array m )
+ aux>> { byte-array } declare swap 1 fixnum-shift-fast ; inline
+
+: small-char? ( ch -- ? ) HEX: 7f fixnum<= ; inline
+
+: string-nth ( n string -- ch )
+ 2dup string-nth-fast dup small-char?
+ [ 2nip ] [
+ [ (aux) alien-unsigned-2 7 fixnum-shift-fast ] dip
+ fixnum-bitxor
+ ] if ; inline
+
+: ensure-aux ( string -- string )
+ dup aux>> [ dup length 2 * (byte-array) >>aux ] unless ; inline
+
+: set-string-nth-slow ( ch n string -- )
+ [ [ HEX: 80 fixnum-bitor ] 2dip set-string-nth-fast ]
+ [
+ ensure-aux
+ [ -7 fixnum-shift-fast 1 fixnum-bitxor ] 2dip
+ (aux) set-alien-unsigned-2
+ ] 3bi ;
+
: set-string-nth ( ch n string -- )
- pick HEX: 7f fixnum<=
+ pick small-char?
[ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
PRIVATE>
! 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 classes.struct accessors alien.data ;
+destructors generalizations kernel libc locals math math.order
+sequences sequences.private classes.struct accessors alien.data
+typed ;
IN: benchmark.yuv-to-rgb
-STRUCT: yuv_buffer
+STRUCT: yuv-buffer
{ y_width int }
{ y_height int }
{ y_stride int }
:: fake-data ( -- rgb yuv )
1600 :> w
1200 :> h
- yuv_buffer <struct> :> buffer
+ yuv-buffer <struct> :> buffer
w h * 3 * <byte-array> :> rgb
rgb buffer
w >>y_width
pick y_width>> iota
[ yuv>rgb-pixel ] with with with with each ; inline
-: yuv>rgb ( rgb yuv -- )
+TYPED: yuv>rgb ( rgb: byte-array yuv: yuv-buffer -- )
[ 0 ] 2dip
dup y_height>> iota
[ yuv>rgb-row ] with with each
drop ;
-HINTS: yuv>rgb byte-array yuv_buffer ;
-
: yuv>rgb-benchmark ( -- )
[ fake-data yuv>rgb ] with-destructors ;
: optimized-cfg ( quot -- cfgs )
{
{ [ dup cfg? ] [ 1array ] }
- { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
- { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
+ { [ dup quotation? ] [ test-optimizer ] }
+ { [ dup word? ] [ test-optimizer ] }
[ ]
} cond ;
/* make an alien */
cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
- if(delegate_ == false_object && displacement == 0)
- return false_object;
+ if(displacement == 0)
+ return delegate_;
data_root<object> delegate(delegate_,this);
data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
break;
#endif
default:
- critical_error("Bad rel type",op.rel_type());
+ critical_error("Bad rel type in store_external_address()",op.rel_type());
break;
}
}
case RT_LITERAL:
op.store_value(next_literal());
break;
- case RT_FLOAT:
- op.store_float(next_literal());
- break;
case RT_ENTRY_POINT:
op.store_value(parent->compute_entry_point_address(next_literal()));
break;
case RT_LITERAL:
op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
break;
- case RT_FLOAT:
- op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
- break;
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
std::ostream &operator<<(std::ostream &out, const string *str)
{
for(cell i = 0; i < string_capacity(str); i++)
- out << (char)str->nth(i);
+ out << (char)str->data()[i];
return out;
}
true /* trace contexts? */);
}
-void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
+void factor_vm::inline_gc(cell gc_roots_)
{
- data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
- primitive_minor_gc();
- data_roots.pop_back();
+ cell stack_pointer = (cell)ctx->callstack_top;
+
+ if(to_boolean(gc_roots_))
+ {
+ tagged<array> gc_roots(gc_roots_);
+
+ cell capacity = array_capacity(gc_roots.untagged());
+ for(cell i = 0; i < capacity; i++)
+ {
+ cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
+ cell *address = (cell *)(spill_slot + stack_pointer);
+ data_roots.push_back(data_root_range(address,1));
+ }
+
+ primitive_minor_gc();
+
+ for(cell i = 0; i < capacity; i++)
+ data_roots.pop_back();
+ }
+ else
+ primitive_minor_gc();
}
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
{
- parent->inline_gc(data_roots_base,data_roots_size);
+ parent->inline_gc(gc_roots);
}
/*
void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
}
case RT_LITERAL:
op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
break;
- case RT_FLOAT:
- op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
- break;
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
return load_value(pointer);
}
-cell instruction_operand::load_float()
-{
- return (cell)load_value() - boxed_float_offset;
-}
-
-cell instruction_operand::load_float(cell pointer)
-{
- return (cell)load_value(pointer) - boxed_float_offset;
-}
-
code_block *instruction_operand::load_code_block(cell relative_to)
{
return ((code_block *)load_value(relative_to) - 1);
}
}
-void instruction_operand::store_float(cell value)
-{
- store_value((fixnum)value + boxed_float_offset);
-}
-
void instruction_operand::store_code_block(code_block *compiled)
{
store_value((cell)compiled->entry_point());
type since its used in a situation where relocation arguments cannot
be passed in, and so RT_DLSYM is inappropriate (Windows only) */
RT_EXCEPTION_HANDLER,
- /* pointer to a float's payload */
- RT_FLOAT,
};
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
case RT_EXCEPTION_HANDLER:
- case RT_FLOAT:
return 0;
default:
- critical_error("Bad rel type",rel_type());
+ critical_error("Bad rel type in number_of_parameters()",rel_type());
return -1; /* Can't happen */
}
}
fixnum load_value_masked(cell mask, cell bits, cell shift);
fixnum load_value(cell relative_to);
fixnum load_value();
- cell load_float(cell relative_to);
- cell load_float();
code_block *load_code_block(cell relative_to);
code_block *load_code_block();
void store_value_2_2(fixnum value);
void store_value_masked(fixnum value, cell mask, cell shift);
void store_value(fixnum value);
- void store_float(cell value);
void store_code_block(code_block *compiled);
};
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
-struct object;
-
#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
struct object {
cell hashcode;
u8 *data() const { return (u8 *)(this + 1); }
-
- cell nth(cell i) const;
};
struct code_block;
cell object;
};
-const fixnum boxed_float_offset = 8 - FLOAT_TYPE;
-
/* Assembly code makes assumptions about the layout of this struct */
struct boxed_float : object {
static const cell type_number = FLOAT_TYPE;
_(set_slot) \
_(set_special_object) \
_(set_string_nth_fast) \
- _(set_string_nth_slow) \
_(size) \
_(sleep) \
_(special_object) \
_(string) \
- _(string_nth) \
_(strip_stack_traces) \
_(system_micros) \
_(tuple) \
void operator()(instruction_operand op)
{
- switch(op.rel_type())
- {
- case RT_LITERAL:
+ if(op.rel_type() == RT_LITERAL)
op.store_value(visitor->visit_pointer(op.load_value()));
- break;
- case RT_FLOAT:
- op.store_float(visitor->visit_pointer(op.load_float()));
- break;
- default:
- break;
- }
}
};
namespace factor
{
-cell string::nth(cell index) const
-{
- /* If high bit is set, the most significant 16 bits of the char
- come from the aux vector. The least significant bit of the
- corresponding aux vector entry is negated, so that we can
- XOR the two components together and get the original code point
- back. */
- cell lo_bits = data()[index];
-
- if((lo_bits & 0x80) == 0)
- return lo_bits;
- else
- {
- byte_array *aux = untag<byte_array>(this->aux);
- cell hi_bits = aux->data<u16>()[index];
- return (hi_bits << 7) ^ lo_bits;
- }
-}
-
-void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
-{
- str->data()[index] = (u8)ch;
-}
-
-void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
-{
- data_root<string> str(str_,this);
-
- byte_array *aux;
-
- str->data()[index] = ((ch & 0x7f) | 0x80);
-
- if(to_boolean(str->aux))
- aux = untag<byte_array>(str->aux);
- else
- {
- /* We don't need to pre-initialize the
- byte array with any data, since we
- only ever read from the aux vector
- if the most significant bit of a
- character is set. Initially all of
- the bits are clear. */
- aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
-
- str->aux = tag<byte_array>(aux);
- write_barrier(&str->aux);
- }
-
- aux->data<u16>()[index] = (u16)((ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void factor_vm::set_string_nth(string *str, cell index, cell ch)
-{
- if(ch <= 0x7f)
- set_string_nth_fast(str,index,ch);
- else
- set_string_nth_slow(str,index,ch);
-}
-
/* Allocates memory */
string *factor_vm::allot_string_internal(cell capacity)
{
data_root<string> str(str_,this);
if(fill <= 0x7f)
- memset(&str->data()[start],(int)fill,capacity - start);
+ memset(&str->data()[start],(u8)fill,capacity - start);
else
{
- cell i;
+ byte_array *aux;
+ if(to_boolean(str->aux))
+ aux = untag<byte_array>(str->aux);
+ else
+ {
+ aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * 2);
+ str->aux = tag<byte_array>(aux);
+ write_barrier(&str->aux);
+ }
- for(i = start; i < capacity; i++)
- set_string_nth(str.untagged(),i,fill);
+ u8 lo_fill = (u8)((fill & 0x7f) | 0x80);
+ u16 hi_fill = (u16)((fill >> 7) ^ 0x1);
+ memset(&str->data()[start],lo_fill,capacity - start);
+ memset_2(&aux->data<u16>()[start],hi_fill,(capacity - start) * sizeof(u16));
}
}
if(to_boolean(str->aux))
{
- byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));
-
+ byte_array *new_aux = allot_uninitialized_array<byte_array>(capacity * 2);
new_str->aux = tag<byte_array>(new_aux);
write_barrier(&new_str->aux);
ctx->push(tag<string>(reallot_string(str.untagged(),capacity)));
}
-void factor_vm::primitive_string_nth()
-{
- string *str = untag<string>(ctx->pop());
- cell index = untag_fixnum(ctx->pop());
- ctx->push(tag_fixnum(str->nth(index)));
-}
-
void factor_vm::primitive_set_string_nth_fast()
{
string *str = untag<string>(ctx->pop());
cell index = untag_fixnum(ctx->pop());
cell value = untag_fixnum(ctx->pop());
- set_string_nth_fast(str,index,value);
-}
-
-void factor_vm::primitive_set_string_nth_slow()
-{
- string *str = untag<string>(ctx->pop());
- cell index = untag_fixnum(ctx->pop());
- cell value = untag_fixnum(ctx->pop());
- set_string_nth_slow(str,index,value);
+ str->data()[index] = (u8)value;
}
}
namespace factor
{
+inline static void memset_2(void *dst, u16 pattern, size_t size)
+{
+#ifdef __APPLE__
+ cell cell_pattern = (pattern | (pattern << 16));
+ memset_pattern4(dst,&cell_pattern,size);
+#else
+ if(pattern == 0)
+ memset(dst,0,size);
+ else
+ {
+ u16 *start = (u16 *)dst;
+ u16 *end = (u16 *)((cell)dst + size);
+ while(start < end)
+ {
+ *start = pattern;
+ start++;
+ }
+ }
+#endif
+}
+
inline static void memset_cell(void *dst, cell pattern, size_t size)
{
#ifdef __APPLE__
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void inline_gc(cell gc_roots);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
object *allot_object(cell type, cell size);
cell std_vector_to_array(std::vector<cell> &elements);
// strings
- cell string_nth(const string *str, cell index);
- void set_string_nth_fast(string *str, cell index, cell ch);
- void set_string_nth_slow(string *str_, cell index, cell ch);
- void set_string_nth(string *str, cell index, cell ch);
string *allot_string_internal(cell capacity);
void fill_string(string *str_, cell start, cell capacity, cell fill);
string *allot_string(cell capacity, cell fill);
bool reallot_string_in_place_p(string *str, cell capacity);
string* reallot_string(string *str_, cell capacity);
void primitive_resize_string();
- void primitive_string_nth();
void primitive_set_string_nth_fast();
- void primitive_set_string_nth_slow();
// booleans
cell tag_boolean(cell untagged)
projects / factor.git / commitdiff