4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-rep >>rep
+ float-rep >>rep
[ >float ] >>unboxer-quot
"float" set-array-class
"float" define-primitive-type
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-rep >>rep
+ double-rep >>rep
[ >float ] >>unboxer-quot
"double" set-array-class
"double" define-primitive-type
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes cpu.architecture compiler.cfg
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
+accessors vectors combinators sets classes cpu.architecture
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
GENERIC: analyze-aliases* ( insn -- insn' )
+M: insn analyze-aliases*
+ dup defs-vreg [ set-heap-ac ] when* ;
+
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##flushable analyze-aliases*
- dup dst>> set-heap-ac ;
-
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
#! vreg, since they both contain the same value.
dup record-copy ;
-M: insn analyze-aliases* ;
-
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
[ f t ] [
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
- [ [ ##slot-imm? ] contains-insn? ] bi
+ [ [ ##unbox-alien? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+ [ { byte-array fixnum } declare alien-cell 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+ [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
] unit-test
\ No newline at end of file
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##conditional-branch? ]
+ [ ##compare-branch? ]
[ ##compare-imm-branch? ]
+ [ ##compare-float-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
M: ##write-barrier build-liveness-graph
dup src>> setter-liveness-graph ;
-M: ##flushable build-liveness-graph
- dup dst>> add-edges ;
-
M: ##allot build-liveness-graph
- [ dst>> allocations get conjoin ]
- [ call-next-method ] bi ;
+ [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
-M: insn build-liveness-graph drop ;
+M: insn build-liveness-graph
+ dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
GENERIC: compute-live-vregs ( insn -- )
M: ##write-barrier compute-live-vregs
dup src>> setter-live-vregs ;
-M: ##flushable compute-live-vregs drop ;
+M: ##fixnum-add compute-live-vregs record-live ;
+
+M: ##fixnum-sub compute-live-vregs record-live ;
+
+M: ##fixnum-mul compute-live-vregs record-live ;
M: insn compute-live-vregs
- record-live ;
+ dup defs-vreg [ drop ] [ record-live ] if ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vreg? ;
-
M: ##set-slot live-insn? obj>> live-vreg? ;
M: ##set-slot-imm live-insn? obj>> live-vreg? ;
M: ##write-barrier live-insn? src>> live-vreg? ;
-M: insn live-insn? drop t ;
+M: ##fixnum-add live-insn? drop t ;
+
+M: ##fixnum-sub live-insn? drop t ;
+
+M: ##fixnum-mul live-insn? drop t ;
+
+M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
: eliminate-dead-code ( cfg -- cfg' )
+ ! Even though we don't use predecessors directly, we depend
+ ! on the predecessors pass updating phi nodes to remove dead
+ ! inputs.
needs-predecessors
init-dead-code
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel assocs sequences namespaces fry
-sets compiler.cfg.rpo compiler.cfg.instructions locals ;
+USING: accessors assocs arrays classes combinators
+compiler.units fry generalizations generic kernel locals
+namespaces quotations sequences sets slots words
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.rpo ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: ##flushable defs-vreg dst>> ;
-M: ##fixnum-overflow defs-vreg dst>> ;
-M: _fixnum-overflow defs-vreg dst>> ;
-M: insn defs-vreg drop f ;
-
-M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp temp-vregs temp>> 1array ;
-M: ##allot temp-vregs temp>> 1array ;
-M: ##dispatch temp-vregs temp>> 1array ;
-M: ##slot temp-vregs temp>> 1array ;
-M: ##set-slot temp-vregs temp>> 1array ;
-M: ##string-nth temp-vregs temp>> 1array ;
-M: ##set-string-nth-fast temp-vregs temp>> 1array ;
-M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##compare temp-vregs temp>> 1array ;
-M: ##compare-imm temp-vregs temp>> 1array ;
-M: ##compare-float temp-vregs temp>> 1array ;
-M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: _dispatch temp-vregs temp>> 1array ;
-M: insn temp-vregs drop f ;
-
-M: ##unary uses-vregs src>> 1array ;
-M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##binary-imm uses-vregs src1>> 1array ;
-M: ##effect uses-vregs src>> 1array ;
-M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
-M: ##slot-imm uses-vregs obj>> 1array ;
-M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
-M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
-M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
-M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
-M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##compare-imm-branch uses-vregs src1>> 1array ;
-M: ##dispatch uses-vregs src>> 1array ;
-M: ##alien-getter uses-vregs src>> 1array ;
-M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
-M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> values ;
-M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: _compare-imm-branch uses-vregs src1>> 1array ;
-M: _dispatch uses-vregs src>> 1array ;
-M: insn uses-vregs drop f ;
+
+<PRIVATE
+
+: slot-array-quot ( slots -- quot )
+ [ reader-word 1quotation ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case ;
+
+: define-defs-vreg-method ( insn -- )
+ [ \ defs-vreg create-method ]
+ [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
+ define ;
+
+: define-uses-vregs-method ( insn -- )
+ [ \ uses-vregs create-method ]
+ [ insn-use-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+: define-temp-vregs-method ( insn -- )
+ [ \ temp-vregs create-method ]
+ [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-method ] each ]
+ [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ [ define-temp-vregs-method ] each ]
+ tri
+] with-compilation-unit
! Computing def-use chains.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math namespaces
-sequences classes.tuple cpu.architecture compiler.cfg.registers
-compiler.cfg.instructions ;
+USING: accessors arrays byte-arrays kernel layouts math
+namespaces sequences combinators splitting parser effects
+words cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
-: ^^r ( -- vreg vreg ) next-vreg dup ; inline
-: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
-: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
-: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
+<<
+
+<PRIVATE
+
+: hat-name ( insn -- word )
+ name>> "##" ?head drop "^^" prepend create-in ;
+
+: hat-quot ( insn -- quot )
+ [
+ "insn-slots" word-prop [ ] [
+ type>> {
+ { def [ [ next-vreg dup ] ] }
+ { temp [ [ next-vreg ] ] }
+ [ drop [ ] ]
+ } case swap [ dip ] curry compose
+ ] reduce
+ ] keep suffix ;
+
+: hat-effect ( insn -- effect )
+ "insn-slots" word-prop
+ [ type>> { def temp } memq? not ] filter [ name>> ] map
+ { "vreg" } <effect> ;
+
+: define-hat ( insn -- )
+ [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
+
+PRIVATE>
+
+insn-classes get [
+ dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+ [ define-hat ] [ drop ] if
+] each
+
+>>
+
+: ^^load-literal ( obj -- dst )
+ [ next-vreg dup ] dip {
+ { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+ { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+ [ ##load-reference ]
+ } cond ; inline
+
+: ^^unbox-c-ptr ( src class -- dst )
+ [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
-: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
-: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
-: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^r2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
-: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
-: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
-: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
-: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
-: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
-: ^^not ( src -- dst ) ^^r1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
-: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
-: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
-: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
-: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
-: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
-: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
-: ^^box-displaced-alien ( base displacement base-class -- dst )
- ^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
-: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
-: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
\ No newline at end of file
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
+: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
+: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
\ No newline at end of file
! Copyright (C) 2008, 2009 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 alien byte-arrays
-compiler.constants combinators compiler.cfg.registers
-compiler.cfg.instructions.syntax ;
+math math.order layouts classes.algebra classes.union
+compiler.units alien byte-arrays compiler.constants combinators
+compiler.cfg.registers compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
+<<
+SYMBOL: insn-classes
+V{ } clone insn-classes set-global
+>>
+
: new-insn ( ... class -- insn ) f swap boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: ##flushable < insn dst ;
+! Instructions which are referentially transparent; used for
+! value numbering
+TUPLE: pure-insn < insn ;
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: ##pure < ##flushable ;
+! Stack operations
+INSN: ##load-immediate
+def: dst/int-rep
+constant: val ;
-TUPLE: ##unary < ##pure src ;
-TUPLE: ##unary/temp < ##unary temp ;
-TUPLE: ##binary < ##pure src1 src2 ;
-TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
-TUPLE: ##commutative < ##binary ;
-TUPLE: ##commutative-imm < ##binary-imm ;
+INSN: ##load-reference
+def: dst/int-rep
+constant: obj ;
-! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn src ;
+INSN: ##peek
+def: dst/int-rep
+literal: loc ;
-! Read/write ops: candidates for alias analysis
-TUPLE: ##read < ##flushable ;
-TUPLE: ##write < ##effect ;
+INSN: ##replace
+use: src/int-rep
+literal: loc ;
-TUPLE: ##alien-getter < ##flushable src ;
-TUPLE: ##alien-setter < ##effect value ;
+INSN: ##inc-d
+literal: n ;
-! Stack operations
-INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-reference < ##pure obj ;
+INSN: ##inc-r
+literal: n ;
-GENERIC: ##load-literal ( dst value -- )
-
-M: fixnum ##load-literal tag-fixnum ##load-immediate ;
-M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-reference ;
+! Subroutine calls
+INSN: ##call
+literal: word ;
-INSN: ##peek < ##flushable { loc loc } ;
-INSN: ##replace < ##effect { loc loc } ;
-INSN: ##inc-d { n integer } ;
-INSN: ##inc-r { n integer } ;
+INSN: ##jump
+literal: word ;
-! Subroutine calls
-INSN: ##call word ;
-INSN: ##jump word ;
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch
+use: src/int-rep
+temp: temp/int-rep ;
! Slot access
-INSN: ##slot < ##read obj slot { tag integer } temp ;
-INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write obj slot { tag integer } temp ;
-INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
+INSN: ##slot
+def: dst/int-rep
+use: obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##slot-imm
+def: dst/int-rep
+use: obj/int-rep
+literal: slot tag ;
+
+INSN: ##set-slot
+use: src/int-rep obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##set-slot-imm
+use: src/int-rep obj/int-rep
+literal: slot tag ;
! String element access
-INSN: ##string-nth < ##flushable obj index temp ;
-INSN: ##set-string-nth-fast < ##effect obj index temp ;
+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
+def: dst
+use: src
+literal: rep ;
! Integer arithmetic
-INSN: ##add < ##commutative ;
-INSN: ##add-imm < ##commutative-imm ;
-INSN: ##sub < ##binary ;
-INSN: ##sub-imm < ##binary-imm ;
-INSN: ##mul < ##commutative ;
-INSN: ##mul-imm < ##commutative-imm ;
-INSN: ##and < ##commutative ;
-INSN: ##and-imm < ##commutative-imm ;
-INSN: ##or < ##commutative ;
-INSN: ##or-imm < ##commutative-imm ;
-INSN: ##xor < ##commutative ;
-INSN: ##xor-imm < ##commutative-imm ;
-INSN: ##shl < ##binary ;
-INSN: ##shl-imm < ##binary-imm ;
-INSN: ##shr < ##binary ;
-INSN: ##shr-imm < ##binary-imm ;
-INSN: ##sar < ##binary ;
-INSN: ##sar-imm < ##binary-imm ;
-INSN: ##min < ##binary ;
-INSN: ##max < ##binary ;
-INSN: ##not < ##unary ;
-INSN: ##log2 < ##unary ;
-
-: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
-: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+PURE-INSN: ##add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##add-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sub-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##mul-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##and
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##and-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##or
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##or-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##xor
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##xor-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shl
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shl-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shr
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shr-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sar
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sar-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##min
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##max
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##not
+def: dst/int-rep
+use: src/int-rep ;
+
+PURE-INSN: ##log2
+def: dst/int-rep
+use: src/int-rep ;
! Bignum/integer conversion
-INSN: ##integer>bignum < ##unary/temp ;
-INSN: ##bignum>integer < ##unary/temp ;
+PURE-INSN: ##integer>bignum
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##bignum>integer
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
! Float arithmetic
-INSN: ##add-float < ##commutative ;
-INSN: ##sub-float < ##binary ;
-INSN: ##mul-float < ##commutative ;
-INSN: ##div-float < ##binary ;
-INSN: ##min-float < ##binary ;
-INSN: ##max-float < ##binary ;
-INSN: ##sqrt < ##unary ;
+PURE-INSN: ##unbox-float
+def: dst/double-rep
+use: src/int-rep ;
+
+PURE-INSN: ##box-float
+def: dst/int-rep
+use: src/double-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##add-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sub-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##mul-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##div-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##min-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##max-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sqrt
+def: dst/double-rep
+use: src/double-rep ;
! libc intrinsics
-INSN: ##unary-float-function < ##unary func ;
-INSN: ##binary-float-function < ##binary func ;
+PURE-INSN: ##unary-float-function
+def: dst/double-rep
+use: src/double-rep
+literal: func ;
-! Float/integer conversion
-INSN: ##float>integer < ##unary ;
-INSN: ##integer>float < ##unary ;
+PURE-INSN: ##binary-float-function
+def: dst/double-rep
+use: src1/double-rep src2/double-rep
+literal: func ;
+
+! Single/double float conversion
+PURE-INSN: ##single>double-float
+def: dst/double-rep
+use: src/float-rep ;
-! Boxing and unboxing
-INSN: ##copy < ##unary rep ;
-INSN: ##unbox-float < ##unary ;
-INSN: ##unbox-any-c-ptr < ##unary/temp ;
-INSN: ##box-float < ##unary/temp ;
-INSN: ##box-alien < ##unary/temp ;
-INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
+PURE-INSN: ##double>single-float
+def: dst/float-rep
+use: src/double-rep ;
+
+! Float/integer conversion
+PURE-INSN: ##float>integer
+def: dst/int-rep
+use: src/double-rep ;
+
+PURE-INSN: ##integer>float
+def: dst/double-rep
+use: src/int-rep ;
+
+! SIMD operations
+
+PURE-INSN: ##box-vector
+def: dst/int-rep
+use: src
+literal: rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##unbox-vector
+def: dst
+use: src/int-rep
+literal: rep ;
+
+PURE-INSN: ##broadcast-vector
+def: dst
+use: src/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-2
+def: dst
+use: src1/scalar-rep src2/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-4
+def: dst
+use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##mul-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##div-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##min-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##max-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sqrt-vector
+def: dst
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+! Boxing and unboxing aliens
+PURE-INSN: ##box-alien
+def: dst/int-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
+temp: temp1/int-rep temp2/int-rep
+literal: base-class ;
+
+PURE-INSN: ##unbox-any-c-ptr
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
-: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+PURE-INSN: ##unbox-alien
+def: dst/int-rep
+use: src/int-rep ;
: ##unbox-c-ptr ( dst src class temp -- )
{
} cond ;
! Alien accessors
-INSN: ##alien-unsigned-1 < ##alien-getter ;
-INSN: ##alien-unsigned-2 < ##alien-getter ;
-INSN: ##alien-unsigned-4 < ##alien-getter ;
-INSN: ##alien-signed-1 < ##alien-getter ;
-INSN: ##alien-signed-2 < ##alien-getter ;
-INSN: ##alien-signed-4 < ##alien-getter ;
-INSN: ##alien-cell < ##alien-getter ;
-INSN: ##alien-float < ##alien-getter ;
-INSN: ##alien-double < ##alien-getter ;
-
-INSN: ##set-alien-integer-1 < ##alien-setter ;
-INSN: ##set-alien-integer-2 < ##alien-setter ;
-INSN: ##set-alien-integer-4 < ##alien-setter ;
-INSN: ##set-alien-cell < ##alien-setter ;
-INSN: ##set-alien-float < ##alien-setter ;
-INSN: ##set-alien-double < ##alien-setter ;
+INSN: ##alien-unsigned-1
+def: dst/int-rep
+use: src/int-rep ;
-! Memory allocation
-INSN: ##allot < ##flushable size class temp ;
+INSN: ##alien-unsigned-2
+def: dst/int-rep
+use: src/int-rep ;
-UNION: ##allocation
-##allot
-##box-float
-##box-alien
-##box-displaced-alien
-##integer>bignum ;
+INSN: ##alien-unsigned-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-1
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-2
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-cell
+def: dst/int-rep
+use: src/int-rep ;
-INSN: ##write-barrier < ##effect card# table ;
+INSN: ##alien-float
+def: dst/float-rep
+use: src/int-rep ;
-INSN: ##alien-global < ##flushable symbol library ;
+INSN: ##alien-double
+def: dst/double-rep
+use: src/int-rep ;
+
+INSN: ##alien-vector
+def: dst
+use: src/int-rep
+literal: rep ;
+
+INSN: ##set-alien-integer-1
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-integer-2
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-integer-4
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-cell
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-float
+use: src/int-rep value/float-rep ;
+
+INSN: ##set-alien-double
+use: src/int-rep value/double-rep ;
+
+INSN: ##set-alien-vector
+use: src/int-rep value
+literal: rep ;
+
+! Memory allocation
+INSN: ##allot
+def: dst/int-rep
+literal: size class
+temp: temp/int-rep ;
+
+INSN: ##write-barrier
+use: src/int-rep
+temp: card#/int-rep table/int-rep ;
+
+INSN: ##alien-global
+def: dst/int-rep
+literal: symbol library ;
! FFI
-INSN: ##alien-invoke params stack-frame ;
-INSN: ##alien-indirect params stack-frame ;
-INSN: ##alien-callback params stack-frame ;
-INSN: ##callback-return params ;
+INSN: ##alien-invoke
+literal: params stack-frame ;
+
+INSN: ##alien-indirect
+literal: params stack-frame ;
+
+INSN: ##alien-callback
+literal: params stack-frame ;
+
+INSN: ##callback-return
+literal: params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##branch ;
-INSN: ##phi < ##pure inputs ;
+INSN: ##phi
+def: dst
+literal: inputs ;
! Conditionals
-TUPLE: ##conditional-branch < insn src1 src2 cc ;
+INSN: ##compare-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-imm-branch
+use: src1/int-rep
+constant: src2
+literal: cc ;
+
+PURE-INSN: ##compare
+def: dst/int-rep
+use: src1/int-rep src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2
+literal: cc
+temp: temp/int-rep ;
+
+INSN: ##compare-float-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
-INSN: ##compare-branch < ##conditional-branch ;
-INSN: ##compare-imm-branch src1 { src2 integer } cc ;
+! Overflowing arithmetic
+INSN: ##fixnum-add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare < ##binary cc temp ;
-INSN: ##compare-imm < ##binary-imm cc temp ;
+INSN: ##fixnum-sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare-float-branch < ##conditional-branch ;
-INSN: ##compare-float < ##binary cc temp ;
+INSN: ##fixnum-mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn dst src1 src2 ;
-INSN: ##fixnum-add < ##fixnum-overflow ;
-INSN: ##fixnum-sub < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow ;
-
-INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: ##gc
+temp: temp1/int-rep temp2/int-rep
+literal: data-values tagged-values uninitialized-locs ;
! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
+INSN: _prologue
+literal: stack-frame ;
+
+INSN: _epilogue
+literal: stack-frame ;
-INSN: _label id ;
+INSN: _label
+literal: label ;
+
+INSN: _branch
+literal: label ;
-INSN: _branch label ;
INSN: _loop-entry ;
-INSN: _dispatch src temp ;
-INSN: _dispatch-label label ;
+INSN: _dispatch
+use: src/int-rep
+temp: temp ;
+
+INSN: _dispatch-label
+literal: label ;
-TUPLE: _conditional-branch < insn label src1 src2 cc ;
+INSN: _compare-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
-INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label src1 { src2 integer } cc ;
+INSN: _compare-imm-branch
+literal: label
+use: src1/int-rep
+constant: src2
+literal: cc ;
-INSN: _compare-float-branch < _conditional-branch ;
+INSN: _compare-float-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
! Overflowing arithmetic
-TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
-INSN: _fixnum-add < _fixnum-overflow ;
-INSN: _fixnum-sub < _fixnum-overflow ;
-INSN: _fixnum-mul < _fixnum-overflow ;
+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 ;
+
+INSN: _fixnum-mul
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: _gc
+temp: temp1 temp2
+literal: data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
-INSN: _spill src rep n ;
-INSN: _reload dst rep n ;
-INSN: _spill-area-size n ;
-
-! Instructions that use vregs
-UNION: vreg-insn
- ##flushable
- ##write-barrier
- ##dispatch
- ##effect
- ##fixnum-overflow
- ##conditional-branch
- ##compare-imm-branch
- ##phi
- ##gc
- _conditional-branch
- _compare-imm-branch
- _dispatch ;
+INSN: _spill
+use: src
+literal: rep n ;
+
+INSN: _reload
+def: dst
+literal: rep n ;
+
+INSN: _spill-area-size
+literal: n ;
+
+UNION: ##allocation
+##allot
+##box-float
+##box-vector
+##box-alien
+##box-displaced-alien
+##integer>bignum ;
+
+! For alias analysis
+UNION: ##read ##slot ##slot-imm ;
+UNION: ##write ##set-slot ##set-slot-imm ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn
- ##unary-float-function
- ##binary-float-function ;
+##unary-float-function
+##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
- ##call
- ##prologue
- ##epilogue
- ##alien-invoke
- ##alien-indirect
- ##alien-callback ;
-
-! Instructions that output floats
-UNION: output-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##sqrt
- ##unary-float-function
- ##binary-float-function
- ##integer>float
- ##unbox-float
- ##alien-float
- ##alien-double ;
-
-! Instructions that take floats as inputs
-UNION: input-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##sqrt
- ##unary-float-function
- ##binary-float-function
- ##float>integer
- ##box-float
- ##set-alien-float
- ##set-alien-double
- ##compare-float
- ##compare-float-branch ;
-
-! Smackdown
-INTERSECTION: ##unary-float ##unary input-float-insn ;
-INTERSECTION: ##binary-float ##binary input-float-insn ;
+##call
+##prologue
+##epilogue
+##alien-invoke
+##alien-indirect
+##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
- ##integer>bignum
- ##bignum>integer
- ##unbox-any-c-ptr ;
\ No newline at end of file
+##integer>bignum
+##bignum>integer
+##unbox-any-c-ptr ;
+
+SYMBOL: vreg-insn
+
+[
+ vreg-insn
+ insn-classes get [
+ "insn-slots" word-prop [ type>> { def use temp } memq? ] any?
+ ] filter
+ define-union-class
+] with-compilation-unit
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser accessors effects ;
+make fry sequences parser accessors effects namespaces
+combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
+SYMBOLS: def use temp literal constant ;
+
+SYMBOL: scalar-rep
+
+TUPLE: insn-slot-spec type name rep ;
+
+: parse-rep ( str/f -- rep )
+ {
+ { [ dup not ] [ ] }
+ { [ dup "scalar-rep" = ] [ drop scalar-rep ] }
+ [ "cpu.architecture" lookup ]
+ } cond ;
+
+: parse-insn-slot-spec ( type string -- spec )
+ over [ "Missing type" throw ] unless
+ "/" split1 parse-rep
+ insn-slot-spec boa ;
+
+: parse-insn-slot-specs ( seq -- specs )
+ [
+ f [
+ {
+ { "def:" [ drop def ] }
+ { "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
+ [ type>> def eq? ] find nip ;
+
+: insn-use-slots ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> use eq? ] filter ;
+
+: insn-temp-slots ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> temp eq? ] filter ;
+
+! We cannot reference words in compiler.cfg.instructions directly
+! since that would create circularity.
+: insn-classes-word ( -- word )
+ "insn-classes" "compiler.cfg.instructions" lookup ;
+
: insn-word ( -- word )
- #! We want to put the insn tuple in compiler.cfg.instructions,
- #! but we cannot have circularity between that vocabulary and
- #! this one.
"insn" "compiler.cfg.instructions" lookup ;
+: pure-insn-word ( -- word )
+ "pure-insn" "compiler.cfg.instructions" lookup ;
+
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
-SYNTAX: INSN:
- parse-tuple-definition "insn#" suffix
- [ dup tuple eq? [ drop insn-word ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
- 3tri ;
+: define-insn-tuple ( class superclass specs -- )
+ [ name>> ] map "insn#" suffix define-tuple-class ;
+
+: define-insn-ctor ( class specs -- )
+ [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
+ [ name>> ] map f <effect> define-declared ;
+
+: define-insn ( class superclass specs -- )
+ parse-insn-slot-specs {
+ [ nip "insn-slots" set-word-prop ]
+ [ 2drop insn-classes-word get push ]
+ [ define-insn-tuple ]
+ [ 2drop save-location ]
+ [ nip define-insn-ctor ]
+ } 3cleave ;
+
+SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ;
^^box-displaced-alien ds-push
] [ emit-primitive ] if ;
-: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
- ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
-
-: (prepare-alien-accessor) ( class -- offset-vreg )
- [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
-
-: prepare-alien-accessor ( infos -- offset-vreg )
- <reversed> [ second class>> ] [ first ] bi
- dup value-info-small-fixnum? [
- literal>> (prepare-alien-accessor-imm)
- ] [ drop (prepare-alien-accessor) ] if ;
-
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
- [ infos prepare-alien-accessor quot call ]
+ [ infos quot call ]
[ node emit-primitive ]
if
] ; inline
[ second class>> fixnum class<= ]
bi and ;
+: prepare-alien-accessor ( info -- offset-vreg )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-getter ( infos -- offset-vreg )
+ first prepare-alien-accessor ;
+
: inline-alien-getter ( node quot -- )
- '[ @ ds-push ]
+ '[ prepare-alien-getter @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
[ third class>> fixnum class<= ]
tri and and ;
+: prepare-alien-setter ( infos -- offset-vreg )
+ second prepare-alien-accessor ;
+
: inline-alien-integer-setter ( node quot -- )
- '[ ds-pop ^^untag-fixnum @ ]
+ '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
- [ dup node-input-infos first class>> ] dip
- '[ ds-pop _ ^^unbox-c-ptr @ ]
+ '[ [ 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 -- )
- '[ ds-pop @ ]
+ '[ prepare-alien-setter ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-float-getter ( node rep -- )
'[
_ {
- { single-float-rep [ ^^alien-float ] }
- { double-float-rep [ ^^alien-double ] }
+ { float-rep [ ^^alien-float ] }
+ { double-rep [ ^^alien-double ] }
} case
] inline-alien-getter ;
: emit-alien-float-setter ( node rep -- )
'[
_ {
- { single-float-rep [ ##set-alien-float ] }
- { double-float-rep [ ##set-alien-double ] }
+ { float-rep [ ##set-alien-float ] }
+ { double-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;
! 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.hats
compiler.cfg.stacks
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
+QUALIFIED: math.vectors.simd.intrinsics
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
{ math.private:float= [ drop cc= emit-float-comparison ] }
{ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ math.private:fixnum>float [ drop emit-fixnum>float ] }
- { alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
- { alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
+ { 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 ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
+: enable-sse2-simd ( -- )
+ {
+ { math.vectors.simd.intrinsics:assert-positive [ drop ] }
+ { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
+ { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
+ { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
+ } enable-intrinsics ;
+
+: enable-sse3-simd ( -- )
+ {
+ { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
+ } enable-intrinsics ;
+
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;
--- /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: accessors byte-arrays fry cpu.architecture kernel
+sequences compiler.tree.propagation.info
+compiler.cfg.builder.blocks compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.intrinsics.alien ;
+IN: compiler.cfg.intrinsics.simd
+
+: emit-vector-op ( node quot: ( rep -- ) -- )
+ [ dup node-input-infos last literal>> ] dip over representation?
+ [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
+
+: emit-binary-vector-op ( node quot -- )
+ '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-unary-vector-op ( node quot -- )
+ '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-gather-vector-2 ( node -- )
+ [ ^^gather-vector-2 ] emit-binary-vector-op ;
+
+: emit-gather-vector-4 ( node -- )
+ [
+ ds-drop
+ [
+ D 3 peek-loc
+ D 2 peek-loc
+ D 1 peek-loc
+ D 0 peek-loc
+ -4 inc-d
+ ] dip
+ ^^gather-vector-4
+ ds-push
+ ] emit-vector-op ;
+
+: emit-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-getter
+ _ ^^alien-vector ds-push
+ ]
+ [ inline-alien-getter? ] inline-alien
+ ] with emit-vector-op ;
+
+: emit-set-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-setter ds-pop
+ _ ##set-alien-vector
+ ]
+ [ byte-array inline-alien-setter? ]
+ inline-alien
+ ] with emit-vector-op ;
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
- pick [ ^^set-slot ] dip ;
+ pick [ next-vreg ##set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
[
[
2dup spill-on-gc?
- [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
H{ } spill-slots set
H{
- { 1 single-float-rep }
- { 2 single-float-rep }
- { 3 single-float-rep }
+ { 1 float-rep }
+ { 2 float-rep }
+ { 3 float-rep }
} representations set
[
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors assocs kernel accessors compiler.cfg.instructions
-lexer parser ;
+USING: accessors arrays assocs fry functors generic.parser
+kernel lexer namespaces parser sequences slots words sets
+compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.renaming.functor
+: slot-change-quot ( slots quot -- quot' )
+ '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
+ [ drop ] append ;
+
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs
GENERIC: rename-insn-defs ( insn -- )
-M: ##flushable rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: ##fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: _fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: insn rename-insn-defs drop ;
+insn-classes get [
+ [ \ rename-insn-defs create-method-in ]
+ [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+ define
+] each
GENERIC: rename-insn-uses ( insn -- )
-M: ##effect rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##unary rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##binary rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##binary-imm rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##slot rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##slot-imm rename-insn-uses
- USE-QUOT change-obj
- drop ;
-
-M: ##set-slot rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##string-nth rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-string-nth-fast rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-slot-imm rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- drop ;
-
-M: ##alien-getter rename-insn-uses
- dup call-next-method
- USE-QUOT change-src
- drop ;
-
-M: ##alien-setter rename-insn-uses
- dup call-next-method
- USE-QUOT change-value
- drop ;
-
-M: ##conditional-branch rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##compare-imm-branch rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##dispatch rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##fixnum-overflow rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
+insn-classes get { ##phi } diff [
+ [ \ rename-insn-uses create-method-in ]
+ [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
+ define
+] each
M: ##phi rename-insn-uses
- [ USE-QUOT assoc-map ] change-inputs
- drop ;
-
-M: insn rename-insn-uses drop ;
+ [ USE-QUOT assoc-map ] change-inputs drop ;
GENERIC: rename-insn-temps ( insn -- )
-M: ##write-barrier rename-insn-temps
- TEMP-QUOT change-card#
- TEMP-QUOT change-table
- drop ;
-
-M: ##unary/temp rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##allot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##string-nth rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-string-nth-fast rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##box-displaced-alien rename-insn-temps
- TEMP-QUOT change-temp1
- TEMP-QUOT change-temp2
- drop ;
-
-M: ##compare rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-imm rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-float rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##gc rename-insn-temps
- TEMP-QUOT change-temp1
- TEMP-QUOT change-temp2
- drop ;
-
-M: _dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: insn rename-insn-temps drop ;
+insn-classes get [
+ [ \ rename-insn-temps create-method-in ]
+ [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
+ define
+] each
;FUNCTOR
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences arrays fry namespaces
-cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.def-use ;
+USING: kernel accessors sequences arrays fry namespaces generic
+words sets combinators generalizations cpu.architecture compiler.units
+compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.def-use ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
-M: ##flushable defs-vreg-rep drop int-rep ;
-M: ##copy defs-vreg-rep rep>> ;
-M: output-float-insn defs-vreg-rep drop double-float-rep ;
-M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
-M: _fixnum-overflow defs-vreg-rep drop int-rep ;
-M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
-M: insn defs-vreg-rep drop f ;
+<PRIVATE
-M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
-M: ##unary/temp temp-vreg-reps drop { int-rep } ;
-M: ##allot temp-vreg-reps drop { int-rep } ;
-M: ##dispatch temp-vreg-reps drop { int-rep } ;
-M: ##slot temp-vreg-reps drop { int-rep } ;
-M: ##set-slot temp-vreg-reps drop { int-rep } ;
-M: ##string-nth temp-vreg-reps drop { int-rep } ;
-M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
-M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
-M: ##compare temp-vreg-reps drop { int-rep } ;
-M: ##compare-imm temp-vreg-reps drop { int-rep } ;
-M: ##compare-float temp-vreg-reps drop { int-rep } ;
-M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
-M: _dispatch temp-vreg-reps drop { int-rep } ;
-M: insn temp-vreg-reps drop f ;
+: rep-getter-quot ( rep -- quot )
+ {
+ { f [ [ rep>> ] ] }
+ { scalar-rep [ [ rep>> scalar-rep-of ] ] }
+ [ [ drop ] swap suffix ]
+ } case ;
-M: ##copy uses-vreg-reps rep>> 1array ;
-M: ##unary uses-vreg-reps drop { int-rep } ;
-M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
-M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
-M: ##binary-imm uses-vreg-reps drop { int-rep } ;
-M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##effect uses-vreg-reps drop { int-rep } ;
-M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
-M: ##slot-imm uses-vreg-reps drop { int-rep } ;
-M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
-M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##dispatch uses-vreg-reps drop { int-rep } ;
-M: ##alien-getter uses-vreg-reps drop { int-rep } ;
-M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: _dispatch uses-vreg-reps drop { int-rep } ;
-M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
-M: insn uses-vreg-reps drop f ;
+: define-defs-vreg-rep-method ( insn -- )
+ [ \ defs-vreg-rep create-method ]
+ [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
+ bi define ;
+
+: reps-getter-quot ( reps -- quot )
+ dup [ rep>> { f scalar-rep } memq? not ] all? [
+ [ rep>> ] map [ drop ] swap suffix
+ ] [
+ [ rep>> rep-getter-quot ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case
+ ] if ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ [ \ uses-vreg-reps create-method ]
+ [ insn-use-slots reps-getter-quot ]
+ bi define ;
+
+: define-temp-vreg-reps-method ( insn -- )
+ [ \ temp-vreg-reps create-method ]
+ [ insn-temp-slots reps-getter-quot ]
+ bi define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-rep-method ] each ]
+ [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ [ define-temp-vreg-reps-method ] each ]
+ tri
+] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
compiler.cfg.representations.preferred ;
IN: compiler.cfg.representations
-[ { double-float-rep double-float-rep } ] [
+[ { double-rep double-rep } ] [
T{ ##add-float
{ dst 5 }
{ src1 3 }
} uses-vreg-reps
] unit-test
-[ double-float-rep ] [
+[ double-rep ] [
T{ ##alien-double
{ dst 5 }
{ src 3 }
cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.def-use
! 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
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##single>double-float
+ int-rep next-vreg-rep ##box-float ;
+
+M: float-rep emit-unbox
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##unbox-float
+ ##double>single-float ;
+
+M: double-rep emit-box
+ drop
+ int-rep next-vreg-rep ##box-float ;
+
+M: double-rep emit-unbox
+ drop ##unbox-float ;
+
+M: vector-rep emit-box
+ int-rep next-vreg-rep ##box-vector ;
+
+M: vector-rep emit-unbox
+ ##unbox-vector ;
+
: emit-conversion ( dst src dst-rep src-rep -- )
- 2array {
- { { int-rep int-rep } [ int-rep ##copy ] }
- { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
- { { double-float-rep int-rep } [ ##unbox-float ] }
- { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
- } case ;
+ {
+ { [ 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
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##sub-float f 1 1 3 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
- { 3 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
+ { 3 double-rep }
} clone representations set
{
T{ ##sub-float f 1 2 3 }
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##mul-float f 1 1 1 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
} clone representations set
{
T{ ##mul-float f 1 2 2 }
##sar-imm
##min
##max
- ##fixnum-overflow
+ ##fixnum-add
+ ##fixnum-sub
+ ##fixnum-mul
##add-float
##sub-float
##mul-float
##div-float
##min-float
- ##max-float ;
+ ##max-float
+ ##add-vector
+ ##sub-vector
+ ##mul-vector
+ ##div-vector
+ ##min-vector
+ ##max-vector ;
GENERIC: convert-two-operand* ( insn -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces combinators
-combinators.short-circuit compiler.cfg.instructions
+USING: accessors classes classes.algebra classes.parser
+classes.tuple combinators combinators.short-circuit fry
+generic.parser kernel math namespaces quotations sequences slots
+splitting words compiler.cfg.instructions
+compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
-! Referentially-transparent expressions
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
-TUPLE: reference-expr < expr value ;
-TUPLE: unary-float-function-expr < expr in func ;
-TUPLE: binary-float-function-expr < expr in1 in2 func ;
-TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
-: <constant> ( constant -- expr )
- f swap constant-expr boa ; inline
+C: <constant> constant-expr
M: constant-expr equal?
over constant-expr? [
} 2&&
] [ 2drop f ] if ;
-: <reference> ( constant -- expr )
- f swap reference-expr boa ; inline
+TUPLE: reference-expr < expr value ;
+
+C: <reference> reference-expr
M: reference-expr equal?
over reference-expr? [
GENERIC: >expr ( insn -- expr )
+M: insn >expr drop next-input-expr ;
+
M: ##load-immediate >expr val>> <constant> ;
M: ##load-reference >expr obj>> <reference> ;
-M: ##unary >expr
- [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
-
-M: ##binary >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: ##binary-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- binary-expr boa ;
-
-M: ##commutative >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- commutative-expr boa ;
-
-M: ##commutative-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- commutative-expr boa ;
-
-: compare>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
-
-M: ##compare >expr compare>expr ;
-
-: compare-imm>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> constant>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
-
-M: ##compare-imm >expr compare-imm>expr ;
-
-M: ##compare-float >expr compare>expr ;
-
-M: ##box-displaced-alien >expr
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ base-class>> ]
- } cleave box-displaced-alien-expr boa ;
-
-M: ##unary-float-function >expr
- [ class ] [ src>> vreg>vn ] [ func>> ] tri
- unary-float-function-expr boa ;
-
-M: ##binary-float-function >expr
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ func>> ]
- } cleave
- binary-float-function-expr boa ;
-
-M: ##flushable >expr drop next-input-expr ;
-
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+<<
+
+: input-values ( slot-specs -- slot-specs' )
+ [ type>> { use literal constant } memq? ] filter ;
+
+: expr-class ( insn -- expr )
+ name>> "##" ?head drop "-expr" append create-class-in ;
+
+: define-expr-class ( insn expr slot-specs -- )
+ [ nip expr ] dip [ name>> ] map define-tuple-class ;
+
+: >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 ;
+
+: define->expr-method ( insn expr slot-specs -- )
+ [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
+
+: handle-pure-insn ( insn -- )
+ [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
+ [ define-expr-class ] [ define->expr-method ] 3bi ;
+
+insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
+
+>>
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
-TUPLE: expr op ;
+TUPLE: expr ;
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
SYMBOL: input-expr-counter
: next-input-expr ( -- expr )
- f input-expr-counter counter input-expr boa ;
+ input-expr-counter counter input-expr boa ;
SYMBOL: vregs>vns
: init-value-graph ( -- )
0 vn-counter set
+ 0 input-expr-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;
} 1&&
] [ drop f ] if ; inline
+: general-compare-expr? ( insn -- ? )
+ { [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ;
+
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
- src1>> vreg>expr compare-expr?
+ src1>> vreg>expr general-compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
- src1>> vreg>expr dup op>> {
- { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
- { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
- } case ;
+ 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-expr? ] [ >compare-expr< \ ##compare-float-branch new-insn ] }
+ } cond ;
: tag-fixnum-expr? ( expr -- ? )
- dup op>> \ ##shl-imm eq?
- [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
+ 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.
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
- [ src1>> vreg>expr in1>> vn>vreg ]
+ [ src1>> vreg>expr src1>> vn>vreg ]
[ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
: rewrite-redundant-comparison? ( insn -- ? )
{
- [ src1>> vreg>expr compare-expr? ]
+ [ src1>> vreg>expr general-compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
- [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
- { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
- } case
+ [ 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-expr? ] [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
+ } cond
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
ERROR: bad-comparison ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
-: reassociate? ( insn -- ? )
- [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
-
: reassociate ( insn op -- insn )
[
{
[ dst>> ]
- [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
+ [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
[ src2>> ]
[ ]
} cleave constant-fold*
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
+ { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} cond ;
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
- { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
+ { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
+ { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
+ { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
+ { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
-: box-displaced-alien? ( expr -- ? )
- op>> \ ##box-displaced-alien eq? ;
-
! ##box-displaced-alien f 1 2 3 <class>
! ##unbox-c-ptr 4 1 <class>
! =>
] { } make ;
M: ##unbox-any-c-ptr rewrite
- dup src>> vreg>expr dup box-displaced-alien?
+ dup src>> vreg>expr dup box-displaced-alien-expr?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions locals ;
+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 )
-: simplify-unbox-alien ( in -- vn/expr/f )
- dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
+M: copy-expr simplify* src>> ;
-M: unary-expr simplify*
- #! Note the copy propagation: a copy always simplifies to
- #! its source VN.
- [ in>> vn>expr ] [ op>> ] bi {
- { \ ##copy [ ] }
- { \ ##unbox-alien [ simplify-unbox-alien ] }
- { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
- [ 2drop f ]
- } case ;
+: 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 f 0 } = ; inline
+: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+ [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
[ 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 ] }
[ 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 ] }
[ 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 ] }
[ 2drop f ]
} cond ; inline
+M: xor-expr simplify* simplify-xor ;
+M: xor-imm-expr simplify* simplify-xor ;
+
: useless-shr? ( in1 in2 -- ? )
- over op>> \ ##shl-imm eq?
- [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+ over shl-imm-expr?
+ [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shr ( expr -- vn/expr/f )
>binary-expr< {
- { [ 2dup useless-shr? ] [ drop in1>> ] }
+ { [ 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: binary-expr simplify*
- dup op>> {
- { \ ##add [ simplify-add ] }
- { \ ##add-imm [ simplify-add ] }
- { \ ##sub [ simplify-sub ] }
- { \ ##sub-imm [ simplify-sub ] }
- { \ ##mul [ simplify-mul ] }
- { \ ##mul-imm [ simplify-mul ] }
- { \ ##and [ simplify-and ] }
- { \ ##and-imm [ simplify-and ] }
- { \ ##or [ simplify-or ] }
- { \ ##or-imm [ simplify-or ] }
- { \ ##xor [ simplify-xor ] }
- { \ ##xor-imm [ simplify-xor ] }
- { \ ##shr [ simplify-shr ] }
- { \ ##shr-imm [ simplify-shr ] }
- { \ ##sar [ simplify-shr ] }
- { \ ##sar-imm [ simplify-shr ] }
- { \ ##shl [ simplify-shl ] }
- { \ ##shl-imm [ simplify-shl ] }
- [ 2drop f ]
- } case ;
+M: shl-expr simplify* simplify-shl ;
+M: shl-imm-expr simplify* simplify-shl ;
M: box-displaced-alien-expr simplify*
[ base>> ] [ displacement>> ] bi {
sequences.deep
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
! Local value numbering.
: >copy ( insn -- insn/##copy )
- dup dst>> dup vreg>vn vn>vreg
+ dup defs-vreg dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
-: rewrite-loop ( insn -- insn' )
- dup rewrite [ rewrite-loop ] [ ] ?if ;
-
GENERIC: process-instruction ( insn -- insn' )
-M: ##flushable process-instruction
- dup rewrite
- [ process-instruction ]
- [ dup number-values >copy ] ?if ;
-
M: insn process-instruction
dup rewrite
- [ process-instruction ] [ ] ?if ;
+ [ process-instruction ]
+ [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
M: array process-instruction
[ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
init-value-graph
- init-expressions
[ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes locals
-source-files.errors
+source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.constants
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+! Special cases
M: ##no-tco generate-insn drop ;
-M: ##load-immediate generate-insn
- [ dst>> ] [ val>> ] bi %load-immediate ;
-
-M: ##load-reference generate-insn
- [ dst>> ] [ obj>> ] bi %load-reference ;
-
-M: ##peek generate-insn
- [ dst>> ] [ loc>> ] bi %peek ;
-
-M: ##replace generate-insn
- [ src>> ] [ loc>> ] bi %replace ;
-
-M: ##inc-d generate-insn n>> %inc-d ;
-
-M: ##inc-r generate-insn n>> %inc-r ;
-
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
-M: ##return generate-insn drop %return ;
-
-M: _dispatch generate-insn
- [ src>> ] [ temp>> ] bi %dispatch ;
-
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
-: >slot< ( insn -- dst obj slot tag )
- { [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##slot generate-insn
- [ >slot< ] [ temp>> ] bi %slot ;
-
-M: ##slot-imm generate-insn
- >slot< %slot-imm ;
-
-: >set-slot< ( insn -- src obj slot tag )
- { [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##set-slot generate-insn
- [ >set-slot< ] [ temp>> ] bi %set-slot ;
-
-M: ##set-slot-imm generate-insn
- >set-slot< %set-slot-imm ;
-
-M: ##string-nth generate-insn
- { [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
-
-M: ##set-string-nth-fast generate-insn
- { [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
-
-: dst/src ( insn -- dst src )
- [ dst>> ] [ src>> ] bi ; inline
-
-: dst/src1/src2 ( insn -- dst src1 src2 )
- [ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
-
-M: ##add generate-insn dst/src1/src2 %add ;
-M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
-M: ##sub generate-insn dst/src1/src2 %sub ;
-M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
-M: ##mul generate-insn dst/src1/src2 %mul ;
-M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
-M: ##and generate-insn dst/src1/src2 %and ;
-M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
-M: ##or generate-insn dst/src1/src2 %or ;
-M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
-M: ##xor generate-insn dst/src1/src2 %xor ;
-M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
-M: ##shl generate-insn dst/src1/src2 %shl ;
-M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
-M: ##shr generate-insn dst/src1/src2 %shr ;
-M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
-M: ##sar generate-insn dst/src1/src2 %sar ;
-M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
-M: ##min generate-insn dst/src1/src2 %min ;
-M: ##max generate-insn dst/src1/src2 %max ;
-M: ##not generate-insn dst/src %not ;
-M: ##log2 generate-insn dst/src %log2 ;
-
-: label/dst/src1/src2 ( insn -- label dst src1 src2 )
- [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
-
-M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
-M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
-M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
-
-: dst/src/temp ( insn -- dst src temp )
- [ dst/src ] [ temp>> ] bi ; inline
-
-M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
-M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
-
-M: ##add-float generate-insn dst/src1/src2 %add-float ;
-M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
-M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
-M: ##div-float generate-insn dst/src1/src2 %div-float ;
-M: ##min-float generate-insn dst/src1/src2 %min-float ;
-M: ##max-float generate-insn dst/src1/src2 %max-float ;
-
-M: ##sqrt generate-insn dst/src %sqrt ;
-
-M: ##unary-float-function generate-insn
- [ dst/src ] [ func>> ] bi %unary-float-function ;
-
-M: ##binary-float-function generate-insn
- [ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
-
-M: ##integer>float generate-insn dst/src %integer>float ;
-M: ##float>integer generate-insn dst/src %float>integer ;
-
-M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
-
-M: ##box-displaced-alien generate-insn
- [ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
-
-M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
-M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
-M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
-M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
-M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
-M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
-M: ##alien-cell generate-insn dst/src %alien-cell ;
-M: ##alien-float generate-insn dst/src %alien-float ;
-M: ##alien-double generate-insn dst/src %alien-double ;
-
-: >alien-setter< ( insn -- src value )
- [ src>> ] [ value>> ] bi ; inline
-
-M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
-M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
-M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
-M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
-M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
-M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
-
-M: ##allot generate-insn
- {
- [ dst>> ]
- [ size>> ]
- [ class>> ]
- [ temp>> ]
- } cleave
- %allot ;
+M: _prologue generate-insn
+ stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-M: ##write-barrier generate-insn
- [ src>> ]
- [ card#>> ]
- [ table>> ]
- tri %write-barrier ;
+M: _epilogue generate-insn
+ stack-frame>> total-size>> %epilogue ;
-! GC checks
+M: _spill-area-size generate-insn drop ;
+
+! 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 ;
+
+: codegen-method-body ( class word -- quot )
+ [
+ "insn-slots" word-prop
+ [ insn-slot-quot ] map cleave>quot
+ ] dip suffix ;
+
+SYNTAX: CODEGEN:
+ scan-word [ \ generate-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
+>>
+
+CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-reference %load-reference
+CODEGEN: ##peek %peek
+CODEGEN: ##replace %replace
+CODEGEN: ##inc-d %inc-d
+CODEGEN: ##inc-r %inc-r
+CODEGEN: ##return %return
+CODEGEN: ##slot %slot
+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: ##sub-imm %sub-imm
+CODEGEN: ##mul %mul
+CODEGEN: ##mul-imm %mul-imm
+CODEGEN: ##and %and
+CODEGEN: ##and-imm %and-imm
+CODEGEN: ##or %or
+CODEGEN: ##or-imm %or-imm
+CODEGEN: ##xor %xor
+CODEGEN: ##xor-imm %xor-imm
+CODEGEN: ##shl %shl
+CODEGEN: ##shl-imm %shl-imm
+CODEGEN: ##shr %shr
+CODEGEN: ##shr-imm %shr-imm
+CODEGEN: ##sar %sar
+CODEGEN: ##sar-imm %sar-imm
+CODEGEN: ##min %min
+CODEGEN: ##max %max
+CODEGEN: ##not %not
+CODEGEN: ##log2 %log2
+CODEGEN: ##copy %copy
+CODEGEN: ##integer>bignum %integer>bignum
+CODEGEN: ##bignum>integer %bignum>integer
+CODEGEN: ##unbox-float %unbox-float
+CODEGEN: ##box-float %box-float
+CODEGEN: ##add-float %add-float
+CODEGEN: ##sub-float %sub-float
+CODEGEN: ##mul-float %mul-float
+CODEGEN: ##div-float %div-float
+CODEGEN: ##min-float %min-float
+CODEGEN: ##max-float %max-float
+CODEGEN: ##sqrt %sqrt
+CODEGEN: ##unary-float-function %unary-float-function
+CODEGEN: ##binary-float-function %binary-float-function
+CODEGEN: ##single>double-float %single>double-float
+CODEGEN: ##double>single-float %double>single-float
+CODEGEN: ##integer>float %integer>float
+CODEGEN: ##float>integer %float>integer
+CODEGEN: ##unbox-vector %unbox-vector
+CODEGEN: ##broadcast-vector %broadcast-vector
+CODEGEN: ##gather-vector-2 %gather-vector-2
+CODEGEN: ##gather-vector-4 %gather-vector-4
+CODEGEN: ##box-vector %box-vector
+CODEGEN: ##add-vector %add-vector
+CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##div-vector %div-vector
+CODEGEN: ##min-vector %min-vector
+CODEGEN: ##max-vector %max-vector
+CODEGEN: ##sqrt-vector %sqrt-vector
+CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##box-alien %box-alien
+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: ##allot %allot
+CODEGEN: ##write-barrier %write-barrier
+CODEGEN: ##compare %compare
+CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-float %compare-float
+
+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-branch %compare-float-branch
+CODEGEN: _dispatch %dispatch
+CODEGEN: _spill %spill
+CODEGEN: _reload %reload
+
+! ##gc
: wipe-locs ( locs temp -- )
'[
_
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp operand n>> int-rep %reload
+ temp int-rep operand n>> %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp operand n>> int-rep %spill ;
+ temp int-rep operand n>> %spill ;
M: object load-gc-root drop %load-gc-root ;
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-M: single-float-rep next-fastcall-param
+M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-M: double-float-rep next-fastcall-param
+M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC: reg-class-full? ( reg-class -- ? )
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
-
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: _label generate-insn
- id>> lookup-label resolve-label ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-: >compare< ( insn -- dst temp cc src1 src2 )
- {
- [ dst>> ]
- [ temp>> ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: ##compare generate-insn >compare< %compare ;
-M: ##compare-imm generate-insn >compare< %compare-imm ;
-M: ##compare-float generate-insn >compare< %compare-float ;
-
-: >binary-branch< ( insn -- label cc src1 src2 )
- {
- [ label>> lookup-label ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: _compare-branch generate-insn
- >binary-branch< %compare-branch ;
-
-M: _compare-imm-branch generate-insn
- >binary-branch< %compare-imm-branch ;
-
-M: _compare-float-branch generate-insn
- >binary-branch< %compare-float-branch ;
-
-M: _spill generate-insn
- [ src>> ] [ n>> ] [ rep>> ] tri %spill ;
-
-M: _reload generate-insn
- [ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
-
-M: _spill-area-size generate-insn drop ;
[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
-[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
\ No newline at end of file
+[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
+
+[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
\ No newline at end of file
V{
T{ ##load-reference f 4 1.5 }
T{ ##unbox-float f 1 4 }
- T{ ##copy f 2 1 double-float-rep }
+ T{ ##copy f 2 1 double-rep }
T{ ##box-float f 3 2 }
T{ ##copy f 0 3 int-rep }
} compile-test-bb
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private
slots.private definitions strings.private vectors hashtables
-generic quotations
+generic quotations alien
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect
-compiler.tree.propagation.transforms ;
+compiler.tree.propagation.transforms
+compiler.tree.propagation.simd ;
IN: compiler.tree.propagation.known-words
{ + - * / }
'[ 2drop _ ] "outputs" set-word-prop
] each
+\ alien-cell [
+ 2drop simple-alien \ f class-or <class-info>
+] "outputs" set-word-prop
+
{ <tuple> <tuple-boa> } [
[
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
] "outputs" set-word-prop
! the output of clone has the same type as the input
+: cloned-value-info ( value-info -- value-info' )
+ clone f >>literal f >>literal?
+ [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
+
{ clone (clone) } [
- [ clone f >>literal f >>literal? ]
- "outputs" set-word-prop
+ [ cloned-value-info ] "outputs" set-word-prop
] each
\ slot [
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals quotations effects ;
+math.intervals quotations effects alien ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+! Type function for 'clone' had a subtle issue
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+M: tuple-with-read-only-slot clone
+ x>> clone tuple-with-read-only-slot boa ; inline
+
+[ V{ object } ] [
+ [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
+] unit-test
+
+! alien-cell outputs a simple-alien or f
+[ t ] [
+ [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
+ first simple-alien class=
+] unit-test
+
! Don't crash if bad literal inputs are passed to unsafe words
[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators
+compiler.tree.propagation.info cpu.architecture kernel words math
+math.intervals math.vectors.simd.intrinsics ;
+IN: compiler.tree.propagation.simd
+
+\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-sum) [
+ nip dup literal?>> [
+ literal>> scalar-rep-of {
+ { float-rep [ float ] }
+ { double-rep [ float ] }
+ } case
+ ] [ drop real ] if
+ <class-info>
+] "outputs" set-word-prop
+
+\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
+
+\ assert-positive [
+ real [0,inf] <class/interval-info> value-info-intersect
+] "outputs" set-word-prop
+
+\ alien-vector { byte-array } "default-output-classes" set-word-prop
! Floating point registers can contain data with
! one of these representations
-SINGLETONS: single-float-rep double-float-rep ;
-
-UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
+SINGLETONS: float-rep double-rep ;
+
+! On x86, floating point registers are really vector registers
+SINGLETONS:
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: vector-rep
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: representation
+any-rep
+tagged-rep
+int-rep
+float-rep
+double-rep
+vector-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
-: reg-class-of ( rep -- reg-class )
- {
- { tagged-rep [ int-regs ] }
- { int-rep [ int-regs ] }
- { single-float-rep [ float-regs ] }
- { double-float-rep [ float-regs ] }
- { stack-params [ stack-params ] }
- } case ;
-
-: rep-size ( rep -- n )
- {
- { tagged-rep [ cell ] }
- { int-rep [ cell ] }
- { single-float-rep [ 4 ] }
- { double-float-rep [ 8 ] }
- { stack-params [ cell ] }
- } case ;
+GENERIC: reg-class-of ( rep -- reg-class )
+
+M: tagged-rep reg-class-of drop int-regs ;
+M: int-rep reg-class-of drop int-regs ;
+M: float-rep reg-class-of drop float-regs ;
+M: double-rep reg-class-of drop float-regs ;
+M: vector-rep reg-class-of drop float-regs ;
+M: stack-params reg-class-of drop stack-params ;
+
+GENERIC: rep-size ( rep -- n )
+
+M: tagged-rep rep-size drop cell ;
+M: int-rep rep-size drop cell ;
+M: float-rep rep-size drop 4 ;
+M: double-rep rep-size drop 8 ;
+M: stack-params rep-size drop cell ;
+M: vector-rep rep-size drop 16 ;
+
+GENERIC: scalar-rep-of ( rep -- rep' )
+
+M: float-4-rep scalar-rep-of drop float-rep ;
+M: double-2-rep scalar-rep-of drop double-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
+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 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src temp -- )
+
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %unary-float-function cpu ( dst src func -- )
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
+HOOK: %single>double-float cpu ( dst src -- )
+HOOK: %double>single-float cpu ( dst src -- )
+
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %copy cpu ( dst src rep -- )
-HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-vector cpu ( dst src temp rep -- )
+HOOK: %unbox-vector cpu ( dst src rep -- )
+
+HOOK: %broadcast-vector cpu ( dst src rep -- )
+HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
+HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
+
+HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %div-vector cpu ( dst src1 src2 rep -- )
+HOOK: %min-vector cpu ( dst src1 src2 rep -- )
+HOOK: %max-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sqrt-vector cpu ( dst src rep -- )
+HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
-HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
HOOK: %alien-cell cpu ( dst src -- )
HOOK: %alien-float cpu ( dst src -- )
HOOK: %alien-double cpu ( dst src -- )
+HOOK: %alien-vector cpu ( dst src rep -- )
HOOK: %set-alien-integer-1 cpu ( ptr value -- )
HOOK: %set-alien-integer-2 cpu ( ptr value -- )
HOOK: %set-alien-cell cpu ( ptr value -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
+HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill cpu ( src n rep -- )
-HOOK: %reload cpu ( dst n rep -- )
+HOOK: %spill cpu ( src rep n -- )
+HOOK: %reload cpu ( dst rep n -- )
HOOK: %loop-entry cpu ( -- )
M: ppc %copy ( dst src rep -- )
{
{ int-rep [ MR ] }
- { double-float-rep [ FMR ] }
+ { double-rep [ FMR ] }
} case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
"f" resolve-label
] with-scope ;
-M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
+M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"alloc" define-label
dst \ t %load-reference
"end" get resolve-label ; inline
-:: %boolean ( dst temp cc -- )
+:: %boolean ( dst cc temp -- )
cc negate-cc order-cc {
{ cc< [ dst temp \ BLT f (%boolean) ] }
{ cc<= [ dst temp \ BLE f (%boolean) ] }
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
-:: (%compare-float) ( cc src1 src2 -- branch1 branch2 )
+:: (%compare-float) ( src1 src2 cc -- branch1 branch2 )
cc {
{ cc< [ src1 src2 (%compare-float-ordered) \ BLT f ] }
{ cc<= [ src1 src2 (%compare-float-ordered) \ BLT \ BEQ ] }
{ cc/<>= [ src1 src2 (%compare-float-unordered) \ BO f ] }
} case ; inline
-M: ppc %compare (%compare) %boolean ;
-M: ppc %compare-imm (%compare-imm) %boolean ;
-M:: ppc %compare-float ( dst temp cc src1 src2 -- )
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float ( dst src1 src2 cc temp -- )
cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
dst temp branch1 branch2 (%boolean) ;
{ cc/= [ label BNE ] }
} case ;
-M: ppc %compare-branch (%compare) %branch ;
-M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M:: ppc %compare-float-branch ( label cc src1 src2 -- )
+M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
+
+M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
+
+M:: ppc %compare-float-branch ( label src1 src2 cc -- )
cc src1 src2 (%compare-float) :> branch2 :> branch1
label branch1 execute( label -- )
branch2 [ label branch2 execute( label -- ) ] when ;
: load-from-frame ( dst n rep -- )
{
{ int-rep [ [ 1 ] dip LWZ ] }
- { single-float-rep [ [ 1 ] dip LFS ] }
- { double-float-rep [ [ 1 ] dip LFD ] }
+ { float-rep [ [ 1 ] dip LFS ] }
+ { double-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
- { single-float-rep [ [ 1 ] dip STFS ] }
- { double-float-rep [ [ 1 ] dip STFD ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
-M: ppc %spill ( src n rep -- )
- [ spill@ ] dip store-to-frame ;
+M: ppc %spill ( src rep n -- )
+ swap [ spill@ ] dip store-to-frame ;
-M: ppc %reload ( dst n rep -- )
- [ spill@ ] dip load-from-frame ;
+M: ppc %reload ( dst rep n -- )
+ swap [ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
M: int-rep store-return-reg drop stack@ EAX MOV ;
-M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
-M: single-float-rep load-return-reg drop next-stack@ FLDS ;
-M: single-float-rep store-return-reg drop stack@ FSTPS ;
+M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: float-rep load-return-reg drop next-stack@ FLDS ;
+M: float-rep store-return-reg drop stack@ FSTPS ;
-M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
-M: double-float-rep load-return-reg drop next-stack@ FLDL ;
-M: double-float-rep store-return-reg drop stack@ FSTPL ;
+M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-rep load-return-reg drop next-stack@ FLDL ;
+M: double-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
4 "double" c-type (>>align)
] unless
-USING: cpu.x86.features cpu.x86.features.private ;
-
-"-no-sse2" (command-line) member? [
- [ { check_sse2 } compile ] with-optimizer
-
- "Checking if your CPU supports SSE2..." print flush
- sse2? [
- " - yes" print
- enable-sse2
- [
- sse2? [
- "This image was built to use SSE2, which your CPU does not support." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] unless
- ] "cpu.x86" add-init-hook
- ] [ " - no" print ] if
-] unless
+USE: vocabs.loader
+
+"cpu.x86.features" require
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
- float-regs return-reg double-float-rep copy-register ;
+ float-regs return-reg double-rep copy-register ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
! Enable fast calling of libc math functions
enable-float-functions
-! SSE2 is always available on x86-64.
-enable-sse2
-
USE: vocabs.loader
{
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
+
+"cpu.x86.features" require
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math alien.syntax ;
+USING: system kernel math alien.syntax combinators locals init io
+cpu.x86 compiler compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE
-FUNCTION: bool check_sse2 ( ) ;
+FUNCTION: int sse_version ( ) ;
FUNCTION: longlong read_timestamp_counter ( ) ;
PRIVATE>
-HOOK: sse2? cpu ( -- ? )
+ALIAS: sse-version sse_version
-M: x86.32 sse2? check_sse2 ;
-
-M: x86.64 sse2? t ;
+: sse-string ( version -- string )
+ {
+ { 00 [ "no SSE" ] }
+ { 10 [ "SSE1" ] }
+ { 20 [ "SSE2" ] }
+ { 30 [ "SSE3" ] }
+ { 33 [ "SSSE3" ] }
+ { 41 [ "SSE4.1" ] }
+ { 42 [ "SSE4.2" ] }
+ } case ;
HOOK: instruction-count cpu ( -- n )
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
+
+USING: cpu.x86.features cpu.x86.features.private ;
+
+:: install-sse-check ( version -- )
+ [
+ sse-version version < [
+ "This image was built to use " write
+ version sse-string write
+ " but your CPU supports " write
+ sse-version sse-string write "." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse ( version -- )
+ {
+ { 00 [ ] }
+ { 10 [ ] }
+ { 20 [ enable-sse2 ] }
+ { 30 [ enable-sse3 ] }
+ { 33 [ enable-sse3 ] }
+ { 41 [ enable-sse3 ] }
+ { 42 [ enable-sse3 ] }
+ } case ;
+
+[ { sse_version } compile ] with-optimizer
+
+"Checking for multimedia extensions: " write sse-version
+[ sse-string write " detected" print ]
+[ install-sse-check ]
+[ enable-sse ] tri
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
-compiler.constants
+compiler.constants byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
M: x86 %not drop NOT ;
M: x86 %log2 BSR ;
+GENERIC: copy-register* ( dst src rep -- )
+
+M: int-rep copy-register* drop MOV ;
+M: tagged-rep copy-register* drop MOV ;
+M: float-rep copy-register* drop MOVSS ;
+M: double-rep copy-register* drop MOVSD ;
+M: float-4-rep copy-register* drop MOVUPS ;
+M: double-2-rep copy-register* drop MOVUPD ;
+M: vector-rep copy-register* drop MOVDQU ;
+
+: copy-register ( dst src rep -- )
+ 2over eq? [ 3drop ] [ copy-register* ] if ;
+
+M: x86 %copy ( dst src rep -- ) copy-register ;
+
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
M: x86 %max-float nip MAXSD ;
M: x86 %sqrt SQRTSD ;
+M: x86 %single>double-float CVTSS2SD ;
+M: x86 %double>single-float CVTSD2SS ;
+
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-GENERIC: copy-register* ( dst src rep -- )
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
-M: int-rep copy-register* drop MOV ;
-M: tagged-rep copy-register* drop MOV ;
-M: single-float-rep copy-register* drop MOVSS ;
-M: double-float-rep copy-register* drop MOVSD ;
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
-: copy-register ( dst src rep -- )
- 2over eq? [ 3drop ] [ copy-register* ] if ;
+M:: x86 %box-vector ( dst src rep temp -- )
+ dst rep rep-size 2 cells + byte-array temp %allot
+ 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
+ dst byte-array-offset [+]
+ src rep copy-register ;
-M: x86 %copy ( dst src rep -- ) copy-register ;
+M:: x86 %unbox-vector ( dst src rep -- )
+ dst src byte-array-offset [+]
+ rep copy-register ;
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
+M: x86 %broadcast-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVAPS ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ MOVAPD ] [ drop dup 0 SHUFPD ] 2bi ] }
+ } case ;
+
+M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
+ rep {
+ {
+ float-4-rep
+ [
+ dst src1 MOVSS
+ dst src2 UNPCKLPS
+ src3 src4 UNPCKLPS
+ dst src3 HEX: 44 SHUFPS
+ ]
+ }
+ } case ;
+
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep {
+ {
+ double-2-rep
+ [
+ dst src1 MOVAPD
+ dst src2 0 SHUFPD
+ ]
+ }
+ } case ;
+
+M: x86 %add-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ADDPS ] }
+ { double-2-rep [ ADDPD ] }
+ { char-16-rep [ PADDB ] }
+ { uchar-16-rep [ PADDB ] }
+ { short-8-rep [ PADDW ] }
+ { ushort-8-rep [ PADDW ] }
+ { int-4-rep [ PADDD ] }
+ { uint-4-rep [ PADDD ] }
+ } case drop ;
+
+M: x86 %sub-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ SUBPS ] }
+ { double-2-rep [ SUBPD ] }
+ { char-16-rep [ PSUBB ] }
+ { uchar-16-rep [ PSUBB ] }
+ { short-8-rep [ PSUBW ] }
+ { ushort-8-rep [ PSUBW ] }
+ { int-4-rep [ PSUBD ] }
+ { uint-4-rep [ PSUBD ] }
+ } case drop ;
+
+M: x86 %mul-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MULPS ] }
+ { double-2-rep [ MULPD ] }
+ { int-4-rep [ PMULLW ] }
+ } case drop ;
+
+M: x86 %div-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ DIVPS ] }
+ { double-2-rep [ DIVPD ] }
+ } case drop ;
+
+M: x86 %min-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MINPS ] }
+ { double-2-rep [ MINPD ] }
+ } case drop ;
+
+M: x86 %max-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MAXPS ] }
+ { double-2-rep [ MAXPD ] }
+ } case drop ;
+
+M: x86 %sqrt-vector ( dst src rep -- )
+ {
+ { float-4-rep [ SQRTPS ] }
+ { double-2-rep [ SQRTPD ] }
+ } case ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %unbox-alien ( dst src -- )
+ alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
"end" resolve-label
] with-scope ;
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
-
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
:: %allot-alien ( dst displacement base temp -- )
"end" resolve-label
] with-scope ;
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
+M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"ok" define-label
M: x86 %alien-signed-4 32 %alien-signed-getter ;
M: x86 %alien-cell [] MOV ;
-M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
+M: x86 %alien-vector [ [] ] dip copy-register ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
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 dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
+M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M:: x86 %compare ( dst temp cc src1 src2 -- )
+M: x86 %compare ( dst src1 src2 cc temp -- )
src1 src2 CMP
cc order-cc {
{ cc< [ dst temp \ CMOVL %boolean ] }
{ cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-imm ( dst temp cc src1 src2 -- )
+M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
: %cmov-float= ( dst src -- )
"no-move" resolve-label
] with-scope ;
-M:: x86 %compare-float ( dst temp cc src1 src2 -- )
+M:: x86 %compare-float ( dst src1 src2 cc temp -- )
cc {
{ cc< [ src2 src1 COMISD dst temp \ CMOVA %boolean ] }
{ cc<= [ src2 src1 COMISD dst temp \ CMOVAE %boolean ] }
{ cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP %boolean ] }
} case ;
-M:: x86 %compare-branch ( label cc src1 src2 -- )
+M:: x86 %compare-branch ( label src1 src2 cc -- )
src1 src2 CMP
cc order-cc {
{ cc< [ label JL ] }
: %jump-float/= ( label -- )
[ JNE ] [ JP ] bi ;
-M:: x86 %compare-float-branch ( label cc src1 src2 -- )
+M:: x86 %compare-float-branch ( label src1 src2 cc -- )
cc {
{ cc< [ src2 src1 COMISD label JA ] }
{ cc<= [ src2 src1 COMISD label JAE ] }
{ cc/<>= [ src1 src2 UCOMISD label JP ] }
} case ;
-M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
-M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
+M:: x86 %spill ( src rep n -- )
+ n spill@ src rep copy-register ;
+
+M:: x86 %reload ( dst rep n -- )
+ dst n spill@ rep copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
: enable-sse2 ( -- )
enable-float-intrinsics
enable-fsqrt
- enable-float-min/max ;
+ enable-float-min/max
+ enable-sse2-simd ;
+
+: enable-sse3 ( -- )
+ enable-sse2
+ enable-sse3-simd ;
enable-min/max
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
+SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
+
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
DEFER: ;FUNCTOR delimiter
{ $subsection euler }
{ $subsection phi }
{ $subsection pi }
-{ $subsection epsilon } ;
+{ $subsection epsilon }
+{ $subsection single-epsilon } ;
ABOUT: "math-constants"
{ $values { "pi" "circumference of circle with diameter 1" } } ;
HELP: epsilon
-{ $values { "epsilon" "smallest floating point value you can add to 1 without underflow" } } ;
+{ $values { "epsilon" "smallest double-precision floating point value you can add to 1 without underflow" } } ;
+
+HELP: single-epsilon
+{ $values { "epsilon" "smallest single-precision floating point value you can add to 1 without underflow" } } ;
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: 2pi ( -- pi ) 2 pi * ; inline
-: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: epsilon ( -- epsilon ) HEX: 3cb0000000000000 bits>double ; foldable
+: single-epsilon ( -- epsilon ) HEX: 34000000 bits>float ; foldable
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
--- /dev/null
+IN: math.vectors.simd.alien.tests
+USING: cpu.architecture math.vectors.simd
+math.vectors.simd.intrinsics accessors math.vectors.simd.alien
+kernel classes.struct tools.test compiler sequences byte-arrays
+alien math kernel.private specialized-arrays.float combinators ;
+
+! Vector alien intrinsics
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
+] unit-test
+
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
+] unit-test
+
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
+] unit-test
+
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
+
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien accessors alien.c-types byte-arrays compiler.units
+cpu.architecture locals kernel math math.vectors.simd
+math.vectors.simd.intrinsics ;
+IN: math.vectors.simd.alien
+
+:: define-simd-128-type ( class rep -- )
+ <c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+
+:: define-simd-256-type ( class rep -- )
+ <c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+[
+ float-4 float-4-rep define-simd-128-type
+ double-2 double-2-rep define-simd-128-type
+ float-8 float-4-rep define-simd-256-type
+ double-4 double-2-rep define-simd-256-type
+] with-compilation-unit
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /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: accessors alien.c-types byte-arrays classes functors
+kernel math parser prettyprint.custom sequences
+sequences.private literals ;
+IN: math.vectors.simd.functor
+
+ERROR: bad-length got expected ;
+
+FUNCTOR: define-simd-128 ( T -- )
+
+N [ 16 T heap-size /i ]
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+NTH [ T dup c-type-getter-boxer array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
+
+A-rep IS ${A}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+TUPLE: A
+{ underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
+
+M: A clone underlying>> clone \ A boa ; inline
+
+M: A length drop N ; inline
+
+M: A nth-unsafe underlying>> NTH call ; inline
+
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length underlying>> length ; inline
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+INSTANCE: A sequence
+
+<PRIVATE
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+
+: A-v->n-op ( v quot -- n )
+ [ underlying>> A-rep ] dip call ; inline
+
+PRIVATE>
+
+;FUNCTOR
+
+! Synthesize 256-bit vectors from a pair of 128-bit vectors
+FUNCTOR: define-simd-256 ( T -- )
+
+N [ 32 T heap-size /i ]
+
+N/2 [ N 2 / ]
+A/2 IS ${T}-${N/2}
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+A-deref DEFINES-PRIVATE ${A}-deref
+
+A-rep IS ${A/2}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+SLOT: underlying1
+SLOT: underlying2
+
+TUPLE: A
+{ underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
+{ underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
+
+M: A clone
+ [ underlying1>> clone ] [ underlying2>> clone ] bi
+ \ A boa ; inline
+
+M: A length drop N ; inline
+
+: A-deref ( n seq -- n' seq' )
+ over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
+
+M: A nth-unsafe A-deref nth-unsafe ; inline
+
+M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length drop 32 ; inline
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+INSTANCE: A sequence
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
+ [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
+ [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
+ dip call ; inline
+
+;FUNCTOR
--- /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 alien alien.c-types cpu.architecture libc ;
+IN: math.vectors.simd.intrinsics
+
+ERROR: bad-simd-call ;
+
+: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
+: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
+: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
+: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
+: assert-positive ( x -- y ) ;
+
+: alien-vector ( c-ptr n rep -- value )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
+
+: set-alien-vector ( value c-ptr n rep -- )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> swap ] dip rep-size memcpy ;
+
--- /dev/null
+USING: help.markup help.syntax sequences math math.vectors
+multiline kernel.private classes.tuple.private
+math.vectors.simd.intrinsics cpu.architecture ;
+IN: math.vectors.simd
+
+ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
+"Modern CPUs support a form of data-level parallelism, where arithmetic operations on fixed-size short vectors can be done on all components in parallel. This is known as single-instruction-multiple-data (SIMD)."
+$nl
+"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
+$nl
+"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
+$nl
+"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
+$nl
+"Since the only difference between ordinary code and SIMD-accelerated code is that the latter uses special fixed-length SIMD sequences, the SIMD library is very easy to use. To ensure your code compiles to use vector instructions without boxing and unboxing overhead, follow the guidelines for " { $link "math.vectors.simd.efficiency" } "."
+$nl
+"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
+
+ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
+"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+$nl
+"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+$nl
+"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
+
+ARTICLE: "math.vectors.simd.types" "SIMD vector types"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
+$nl
+"The following vector types are defined:"
+{ $subsection float-4 }
+{ $subsection double-2 }
+{ $subsection float-8 }
+{ $subsection double-4 }
+"For each vector type, several words are defined:"
+{ $table
+ { "Word" "Stack effect" "Description" }
+ { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
+ { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
+ { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
+ { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
+}
+"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
+$nl
+"Operations on " { $link float-4 } " instances:"
+{ $subsection float-4-with }
+{ $subsection float-4-boa }
+{ $subsection POSTPONE: float-4{ }
+"Operations on " { $link double-2 } " instances:"
+{ $subsection double-2-with }
+{ $subsection double-2-boa }
+{ $subsection POSTPONE: double-2{ }
+"Operations on " { $link float-8 } " instances:"
+{ $subsection float-8-with }
+{ $subsection float-8-boa }
+{ $subsection POSTPONE: float-8{ }
+"Operations on " { $link double-4 } " instances:"
+{ $subsection double-4-with }
+{ $subsection double-4-boa }
+{ $subsection POSTPONE: double-4{ }
+"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
+{ $see-also "c-types-specs" } ;
+
+ARTICLE: "math.vectors.simd.efficiency" "Writing efficient SIMD code"
+"Since SIMD vectors are heap-allocated objects, it is important to write code in a style which is conducive to the compiler being able to inline generic dispatch and eliminate allocation."
+$nl
+"If the inputs to a " { $vocab-link "math.vectors" } " word are statically known to be SIMD vectors, the call is converted into an SIMD primitive, and the output is then also known to be an SIMD vector (or scalar, depending on the operation); this information propagates forward within a single word (together with any inlined words and macro expansions). Any intermediate values which are not stored into collections, or returned from the word, are furthermore unboxed."
+$nl
+"To check if optimizations are being performed, pass a quotation to the " { $snippet "optimizer-report." } " and " { $snippet "optimized." } " words in the " { $vocab-link "compiler.tree.debugger" } " vocabulary, and look for calls to " { $link "math.vectors.simd.intrinsics" } " as opposed to high-level " { $link "math-vectors" } "."
+$nl
+"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors
+math.vectors.simd ;
+SYMBOLS: x y ;
+
+[
+ double-4{ 1.5 2.0 3.7 0.4 } x set
+ double-4{ 1.5 2.0 3.7 0.4 } y set
+ x get y get v+
+] optimizer-report."> }
+"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
+{ $code
+<" USING: compiler.tree.debugger kernel.private
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ { float-4 float-4 float-4 } declare
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+\ interpolate optimizer-report. "> }
+"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
+$nl
+"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
+{ $code
+<" USING: compiler.tree.debugger hints
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+HINTS: interpolate float-4 float-4 float-4 ;
+
+\ interpolate optimizer-report. "> }
+"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
+$nl
+"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
+$nl
+"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+IN: simd-demo
+
+STRUCT: actor
+{ id int }
+{ position float-4 }
+{ velocity float-4 }
+{ acceleration float-4 } ;
+
+GENERIC: advance ( dt object -- )
+
+: update-velocity ( dt actor -- )
+ [ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri
+ (>>velocity) ; inline
+
+: update-position ( dt actor -- )
+ [ velocity>> n*v ] [ position>> v+ ] [ ] tri
+ (>>position) ; inline
+
+M: actor advance ( dt actor -- )
+ [ >float ] dip
+ [ update-velocity ] [ update-position ] 2bi ;
+
+M\ actor advance optimized.">
+}
+"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
+{ $code
+<" USE: compiler.tree.debugger
+
+M\ actor advance test-mr mr.">
+"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." } ;
+
+ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
+"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
+{ $list
+ "They operate on raw byte arrays, with a separate “representation” parameter passed in to determine the type of the operands and result."
+ "They are unsafe; passing values which are not byte arrays, or byte arrays with the wrong size, will dereference invalid memory and possibly crash Factor."
+ { "They do not have software fallbacks; if the current CPU does not have SIMD support, a " { $link bad-simd-call } " error will be thrown." }
+}
+"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
+$nl
+"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+{ $subsection (simd-v+) }
+{ $subsection (simd-v-) }
+{ $subsection (simd-v/) }
+{ $subsection (simd-vmin) }
+{ $subsection (simd-vmax) }
+{ $subsection (simd-vsqrt) }
+{ $subsection (simd-sum) }
+{ $subsection (simd-broadcast) }
+{ $subsection (simd-gather-2) }
+{ $subsection (simd-gather-4) }
+"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
+{ $subsection alien-vector }
+{ $subsection set-alien-vector }
+"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
+
+ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
+"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
+{ $code
+<" float-4
+double-2
+float-8
+double-4"> }
+"Passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
+"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
+{ $subsection "math.vectors.simd.intro" }
+{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.efficiency" }
+{ $subsection "math.vectors.simd.alien" }
+{ $subsection "math.vectors.simd.intrinsics" } ;
+
+! ! ! float-4
+
+HELP: float-4
+{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
+
+HELP: float-4-with
+{ $values { "x" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: float-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: float-4{
+{ $syntax "float-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link float-4 } "." } ;
+
+! ! ! double-2
+
+HELP: double-2
+{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
+
+HELP: double-2-with
+{ $values { "x" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector with both components equal to a scalar." } ;
+
+HELP: double-2-boa
+{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector from two scalar components." } ;
+
+HELP: double-2{
+{ $syntax "double-2{ a b }" }
+{ $description "Literal syntax for a " { $link double-2 } "." } ;
+
+! ! ! float-8
+
+HELP: float-8
+{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
+
+HELP: float-8-with
+{ $values { "x" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector with all eight components equal to a scalar." } ;
+
+HELP: float-8-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector from eight scalar components." } ;
+
+HELP: float-8{
+{ $syntax "float-8{ a b c d e f g h }" }
+{ $description "Literal syntax for a " { $link float-8 } "." } ;
+
+! ! ! double-4
+
+HELP: double-4
+{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
+
+HELP: double-4-with
+{ $values { "x" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: double-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: double-4{
+{ $syntax "double-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link double-4 } "." } ;
+
+ABOUT: "math.vectors.simd"
--- /dev/null
+IN: math.vectors.simd.tests
+USING: math math.vectors.simd math.vectors.simd.private
+math.vectors math.functions kernel.private compiler sequences
+tools.test compiler.tree.debugger accessors kernel ;
+
+[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+
+[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
+
+[ float-4{ 12 12 12 12 } ] [
+ 12 [ float-4-with ] compile-call
+] unit-test
+
+[ float-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ float-4-boa ] compile-call
+] unit-test
+
+[ float-4{ 11 22 33 44 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v+ ] compile-call
+] unit-test
+
+[ float-4{ -9 -18 -27 -36 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v- ] compile-call
+] unit-test
+
+[ float-4{ 10 40 90 160 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v* ] compile-call
+] unit-test
+
+[ float-4{ 10 100 1000 10000 } ] [
+ float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v/ ] compile-call
+] unit-test
+
+[ float-4{ -10 -20 -30 -40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmin ] compile-call
+] unit-test
+
+[ float-4{ 10 20 30 40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
+ [ { float-4 float-4 } declare v. ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ 5.0 float-4{ 1 2 3 4 }
+ [ { float float-4 } declare n*v ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ float-4{ 1 2 3 4 } 5.0
+ [ { float float-4 } declare v*n ] compile-call
+] unit-test
+
+[ float-4{ 10 5 2 5 } ] [
+ 10.0 float-4{ 1 2 5 2 }
+ [ { float float-4 } declare n/v ] compile-call
+] unit-test
+
+[ float-4{ 0.5 1 1.5 2 } ] [
+ float-4{ 1 2 3 4 } 2
+ [ { float float-4 } declare v/n ] compile-call
+] unit-test
+
+[ float-4{ 1 0 0 0 } ] [
+ float-4{ 10 0 0 0 }
+ [ { float-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ float-4{ 1 0 0 0 }
+ float-4{ 0 1 0 0 }
+ [ { float-4 float-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-2{ 12 12 } ] [
+ 12 [ double-2-with ] compile-call
+] unit-test
+
+[ double-2{ 1 2 } ] [
+ 1 2 [ double-2-boa ] compile-call
+] unit-test
+
+[ double-2{ 11 22 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ ] compile-call
+] unit-test
+
+[ double-2{ -9 -18 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v- ] compile-call
+] unit-test
+
+[ double-2{ 10 40 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v* ] compile-call
+] unit-test
+
+[ double-2{ 10 100 } ] [
+ double-2{ 100 2000 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v/ ] compile-call
+] unit-test
+
+[ double-2{ -10 -20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmin ] compile-call
+] unit-test
+
+[ double-2{ 10 20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmax ] compile-call
+] unit-test
+
+[ 3.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum ] compile-call
+] unit-test
+
+[ 7.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum 4.0 + ] compile-call
+] unit-test
+
+[ 16.0 ] [
+ double-2{ 1 2 } double-2{ 2 7 }
+ [ { double-2 double-2 } declare v. ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ 5.0 double-2{ 1 2 }
+ [ { float double-2 } declare n*v ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ double-2{ 1 2 } 5.0
+ [ { float double-2 } declare v*n ] compile-call
+] unit-test
+
+[ double-2{ 10 5 } ] [
+ 10.0 double-2{ 1 2 }
+ [ { float double-2 } declare n/v ] compile-call
+] unit-test
+
+[ double-2{ 0.5 1 } ] [
+ double-2{ 1 2 } 2
+ [ { float double-2 } declare v/n ] compile-call
+] unit-test
+
+[ double-2{ 0 0 } ] [ double-2 new ] unit-test
+
+[ double-2{ 1 0 } ] [
+ double-2{ 10 0 }
+ [ { double-2 } declare normalize ] compile-call
+] unit-test
+
+[ 5.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-2{ 1 0 }
+ double-2{ 0 1 }
+ [ { double-2 double-2 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 double-4-boa
+] unit-test
+
+[ double-4{ 1 1 1 1 } ] [
+ 1 double-4-with
+] unit-test
+
+[ double-4{ 0 1 2 3 } ] [
+ 1 double-4-with [ * ] map-index
+] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
+
+[ double-4{ 12 12 12 12 } ] [
+ 12 [ double-4-with ] compile-call
+] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ double-4-boa ] compile-call
+] unit-test
+
+[ double-4{ 11 22 33 44 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v+ ] compile-call
+] unit-test
+
+[ double-4{ -9 -18 -27 -36 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v- ] compile-call
+] unit-test
+
+[ double-4{ 10 40 90 160 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v* ] compile-call
+] unit-test
+
+[ double-4{ 10 100 1000 10000 } ] [
+ double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v/ ] compile-call
+] unit-test
+
+[ double-4{ -10 -20 -30 -40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmin ] compile-call
+] unit-test
+
+[ double-4{ 10 20 30 40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
+ [ { double-4 double-4 } declare v. ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ 5.0 double-4{ 1 2 3 4 }
+ [ { float double-4 } declare n*v ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ double-4{ 1 2 3 4 } 5.0
+ [ { float double-4 } declare v*n ] compile-call
+] unit-test
+
+[ double-4{ 10 5 2 5 } ] [
+ 10.0 double-4{ 1 2 5 2 }
+ [ { float double-4 } declare n/v ] compile-call
+] unit-test
+
+[ double-4{ 0.5 1 1.5 2 } ] [
+ double-4{ 1 2 3 4 } 2
+ [ { float double-4 } declare v/n ] compile-call
+] unit-test
+
+[ double-4{ 1 0 0 0 } ] [
+ double-4{ 10 0 0 0 }
+ [ { double-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-4{ 1 0 0 0 }
+ double-4{ 0 1 0 0 }
+ [ { double-4 double-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
+
+[ float-8{ 3 6 9 12 15 18 21 24 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v+ ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v- ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ -0.5
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float float-8 } declare n*v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -0.5
+ [ { float-8 float } declare v*n ] compile-call
+] unit-test
+
+[ float-8{ 256 128 64 32 16 8 4 2 } ] [
+ 256.0
+ float-8{ 1 2 4 8 16 32 64 128 }
+ [ { float float-8 } declare n/v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -2.0
+ [ { float-8 float } declare v/n ] compile-call
+] unit-test
+
+! Test puns
+[ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+] unit-test
+
+[ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays cpu.architecture
+kernel math math.functions math.vectors
+math.vectors.simd.functor math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private specialized-arrays.double locals assocs
+words fry ;
+IN: math.vectors.simd
+
+<<
+
+DEFER: float-4
+DEFER: double-2
+DEFER: float-8
+DEFER: double-4
+
+"double" define-simd-128
+"float" define-simd-128
+"double" define-simd-256
+"float" define-simd-256
+
+>>
+
+: float-4-with ( x -- simd-array )
+ [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
+
+: float-4-boa ( a b c d -- simd-array )
+ \ float-4 new 4sequence ;
+
+: double-2-with ( x -- simd-array )
+ [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
+
+: double-2-boa ( a b -- simd-array )
+ \ double-2 new 2sequence ;
+
+! More efficient expansions for the above, used when SIMD is
+! actually available.
+
+<<
+
+\ float-4-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
+ ] [ \ float-4-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ float-4-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [| a b c d |
+ a >float b >float c >float d >float
+ float-4-rep (simd-gather-4) \ float-4 boa
+ ]
+ ] [ \ float-4-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
+ ] [ \ double-2-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
+ ] [ \ double-2-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+>>
+
+: float-8-with ( x -- simd-array )
+ [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+:: float-8-boa ( a b c d e f g h -- simd-array )
+ a b c d float-4-boa
+ e f g h float-4-boa
+ [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+: double-4-with ( x -- simd-array )
+ [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+:: double-4-boa ( a b c d -- simd-array )
+ a b double-2-boa
+ c d double-2-boa
+ [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+<<
+
+<PRIVATE
+
+! Filter out operations that are not available, eg horizontal adds
+! on SSE2. Fallback code in math.vectors is used in that case.
+
+: supported-simd-ops ( assoc -- assoc' )
+ {
+ { v+ (simd-v+) }
+ { v- (simd-v-) }
+ { v* (simd-v*) }
+ { v/ (simd-v/) }
+ { vmin (simd-vmin) }
+ { vmax (simd-vmax) }
+ { sum (simd-sum) }
+ } [ nip "intrinsic" word-prop ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+! Some SIMD operations are defined in terms of others.
+
+:: high-level-ops ( ctor -- assoc )
+ {
+ { vneg [ [ dup v- ] keep v- ] }
+ { v. [ v* sum ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ { distance [ v- norm ] }
+ } ;
+
+:: simd-vector-words ( class ctor elt-type assoc -- )
+ class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
+ specialize-vector-words ;
+
+PRIVATE>
+
+\ float-4 \ float-4-with float H{
+ { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
+ { sum [ [ (simd-sum) ] float-4-v->n-op ] }
+} simd-vector-words
+
+\ double-2 \ double-2-with float H{
+ { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
+ { sum [ [ (simd-sum) ] double-2-v->n-op ] }
+} simd-vector-words
+
+\ float-8 \ float-8-with float H{
+ { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
+ { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
+} simd-vector-words
+
+\ double-4 \ double-4-with float H{
+ { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
+ { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
+} simd-vector-words
+
+>>
+
+USE: vocabs.loader
+
+"math.vectors.simd.alien" require
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects kernel.private accessors
combinators math math.intervals math.vectors namespaces assocs fry
-splitting classes.algebra generalizations
+splitting classes.algebra generalizations locals
compiler.tree.propagation.info ;
IN: math.vectors.specialization
{ vmin { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
+ { sum { +vector+ -> +scalar+ } }
}
SYMBOL: specializations
: outputs ( schema -- seq ) { -> } split second ;
-: specialize-vector-word ( word array-type elt-type -- word' )
+: loop-vector-op ( word array-type elt-type -- word' )
pick word-schema
[ inputs (specialize-vector-word) ]
[ outputs record-output-signature ] 3bi ;
-: input-signature ( word -- signature ) def>> first ;
+:: specialize-vector-word ( word array-type elt-type simd -- word/quot' )
+ word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ;
-: specialize-vector-words ( array-type elt-type -- )
- [ vector-words keys ] 2dip
- '[
- [ _ _ specialize-vector-word ] keep
- [ dup input-signature ] dip
- add-specialization
+:: input-signature ( word array-type elt-type -- signature )
+ array-type elt-type word word-schema inputs signature-for-schema ;
+
+:: specialize-vector-words ( array-type elt-type simd -- )
+ vector-words keys [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
] each ;
: find-specialization ( classes word -- word/f )
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
-"Any Factor sequence can be used to represent a mathematical vector."
+"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
$nl
"Acting on vectors by a scalar:"
{ $subsection vneg }
{ $subsection n*v }
{ $subsection v/n }
{ $subsection n/v }
+{ $subsection v+n }
+{ $subsection n+v }
+{ $subsection v-n }
+{ $subsection n-v }
"Combining two vectors to form another vector with " { $link 2map } ":"
{ $subsection v+ }
{ $subsection v- }
INSTANCE: A specialized-array
-A T c-type-boxed-class specialize-vector-words
+A T c-type-boxed-class f specialize-vector-words
T c-type
\ A >>array-class
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
] unit-test
+[ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
+
+[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
+
[ ushort-array{ 0 0 0 } ] [
3 ALIEN: 123 100 <direct-ushort-array> new-sequence
dup [ drop 0 ] change-each
-] unit-test
\ No newline at end of file
+] unit-test
IN: struct-arrays.tests
USING: classes.struct struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors sequences.private
-compiler.tree.debugger ;
+compiler.tree.debugger combinators.smart ;
STRUCT: test-struct-array
{ x int }
{ y int } ;
+[ 1 ] [
+ 1 struct-array{ test-struct-array } new-sequence length
+] unit-test
+
+[ V{ test-struct-array } ] [
+ [ [ test-struct-array <struct> ] struct-array{ test-struct-array } output>sequence first ] final-classes
+] unit-test
+
: make-point ( x y -- struct )
test-struct-array <struct-boa> ;
tri struct-array boa ; inline
M: struct-array new-sequence
- [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
+ [ element-size>> * (byte-array) ] [ class>> ] 2bi
<direct-struct-array> ; inline
M: struct-array resize ( n seq -- newseq )
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
- over tuple? [
- [ [ layout-of ] dip key? ]
- [ drop class "forgotten" word-prop not ]
- 2bi and
- ] [ 2drop f ] if ;
+ [ [ layout-of ] dip key? ]
+ [ drop class "forgotten" word-prop not ]
+ 2bi and ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [ outdated-tuple? ] curry instances
+ [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
dup [ update-tuple ] map become
] if ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel locals math math.constants
+math.functions math.vectors math.vectors.simd prettyprint
+combinators.smart sequences hints struct-arrays classes.struct ;
+IN: benchmark.nbody-simd
+
+: solar-mass ( -- x ) 4 pi sq * ; inline
+CONSTANT: days-per-year 365.24
+
+STRUCT: body
+{ location double-4 }
+{ velocity double-4 }
+{ mass double } ;
+
+: <body> ( location velocity mass -- body )
+ [ days-per-year v*n ] [ solar-mass * ] bi* body <struct-boa> ; inline
+
+: <jupiter> ( -- body )
+ double-4{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 0.0 }
+ double-4{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 0.0 }
+ 9.54791938424326609e-04
+ <body> ;
+
+: <saturn> ( -- body )
+ double-4{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 0.0 }
+ double-4{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 0.0 }
+ 2.85885980666130812e-04
+ <body> ;
+
+: <uranus> ( -- body )
+ double-4{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 0.0 }
+ double-4{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 0.0 }
+ 4.36624404335156298e-05
+ <body> ;
+
+: <neptune> ( -- body )
+ double-4{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 0.0 }
+ double-4{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 0.0 }
+ 5.15138902046611451e-05
+ <body> ;
+
+: <sun> ( -- body )
+ double-4{ 0 0 0 0 } double-4{ 0 0 0 0 } 1 <body> ;
+
+: offset-momentum ( body offset -- body )
+ vneg solar-mass v/n >>velocity ; inline
+
+TUPLE: nbody-system { bodies struct-array read-only } ;
+
+: init-bodies ( bodies -- )
+ [ first ] [ [ [ velocity>> ] [ mass>> ] bi v*n ] [ v+ ] map-reduce ] bi
+ offset-momentum drop ; inline
+
+: <nbody-system> ( -- system )
+ [ <sun> <jupiter> <saturn> <uranus> <neptune> ]
+ struct-array{ body } output>sequence nbody-system boa
+ dup bodies>> init-bodies ; inline
+
+:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+ bodies [| body i |
+ body each-quot call
+ bodies i 1 + tail-slice [
+ body pair-quot call
+ ] each
+ ] each-index ; inline
+
+: update-position ( body dt -- )
+ [ dup velocity>> ] dip '[ _ _ v*n v+ ] change-location drop ; inline
+
+: mag ( dt body other-body -- mag d )
+ [ location>> ] bi@ v- [ norm-sq dup sqrt * / ] keep ; inline
+
+:: update-velocity ( other-body body dt -- )
+ dt body other-body mag
+ [ [ body ] 2dip '[ other-body mass>> _ * _ n*v v- ] change-velocity drop ]
+ [ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ; inline
+
+: advance ( system dt -- )
+ [ bodies>> ] dip
+ [ '[ _ update-velocity ] [ drop ] each-pair ]
+ [ '[ _ update-position ] each ]
+ 2bi ; inline
+
+: inertia ( body -- e )
+ [ mass>> ] [ velocity>> norm-sq ] bi * 0.5 * ; inline
+
+: newton's-law ( other-body body -- e )
+ [ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ; inline
+
+: energy ( system -- x )
+ [ 0.0 ] dip bodies>> [ newton's-law - ] [ inertia + ] each-pair ; inline
+
+: nbody ( n -- )
+ >fixnum
+ <nbody-system>
+ [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+
+: nbody-main ( -- ) 1000000 nbody ;
+
+MAIN: nbody-main
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: arrays accessors specialized-arrays.double io io.files
-io.files.temp io.encodings.binary kernel math math.functions
-math.vectors math.parser make sequences sequences.private words
-hints ;
+io.files.temp io.encodings.binary kernel math math.constants
+math.functions math.vectors math.parser make sequences
+sequences.private words hints ;
IN: benchmark.raytracer
! parameters
CONSTANT: size 200
-CONSTANT: delta 1.4901161193847656E-8
+: delta ( -- n ) epsilon sqrt ; inline
TUPLE: ray { orig double-array read-only } { dir double-array read-only } ;
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
-/* cpu.x86.32 calls this */
-DEF(bool,check_sse2,(void)):
- push %ebx
- mov $1,%eax
- cpuid
- shr $26,%edx
- and $1,%edx
- pop %ebx
- mov %edx,%eax
- ret
-
DEF(long long,read_timestamp_counter,(void)):
rdtsc
ret
#ifdef WINDOWS
.section .drectve
- .ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
#endif
add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+/* cpu.x86.features calls this */
+DEF(bool,sse_version,(void)):
+ mov $0x1,RETURN_REG
+ cpuid
+ test $0x100000,%ecx
+ jnz sse_42
+ test $0x80000,%ecx
+ jnz sse_41
+ test $0x200,%ecx
+ jnz ssse_3
+ test $0x1,%ecx
+ jnz sse_3
+ test $0x4000000,%edx
+ jnz sse_2
+ test $0x2000000,%edx
+ jnz sse_1
+ mov $0,%eax
+ ret
+sse_42:
+ mov $42,RETURN_REG
+ ret
+sse_41:
+ mov $41,RETURN_REG
+ ret
+ssse_3:
+ mov $33,RETURN_REG
+ ret
+sse_3:
+ mov $30,RETURN_REG
+ ret
+sse_2:
+ mov $20,RETURN_REG
+ ret
+sse_1:
+ mov $10,RETURN_REG
+ ret
#ifdef WINDOWS
.section .drectve
+ .ascii " -export:sse_version"
.ascii " -export:c_to_factor"
#endif
projects / factor.git / commitdiff