! 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 ;
: 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 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 )
+ [ [ drop f ] ] [
+ [ reader-word 1quotation ] map
+ dup length '[ _ cleave _ narray ]
+ ] if-empty ;
+
+: 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 ;
-
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: ##pure < ##flushable ;
+! Instructions which are referentially transparent; used for
+! value numbering
+TUPLE: pure-insn < insn ;
-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 ;
+! Stack operations
+INSN: ##load-immediate
+def: dst/int-rep
+constant: val ;
-! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn src ;
+INSN: ##load-reference
+def: dst/int-rep
+constant: obj ;
-! Read/write ops: candidates for alias analysis
-TUPLE: ##read < ##flushable ;
-TUPLE: ##write < ##effect ;
+INSN: ##peek
+def: dst/int-rep
+literal: loc ;
-TUPLE: ##alien-getter < ##flushable src ;
-TUPLE: ##alien-setter < ##effect value ;
+INSN: ##replace
+use: src/int-rep
+literal: loc ;
-! Stack operations
-INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-reference < ##pure obj ;
+INSN: ##inc-d
+literal: n ;
-GENERIC: ##load-literal ( dst value -- )
+INSN: ##inc-r
+literal: n ;
-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 ;
! 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: ##add-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##sub-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##mul-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##div-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##min-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##max-float
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep ;
+
+PURE-INSN: ##sqrt
+def: dst/double-float-rep
+use: src/double-float-rep ;
! libc intrinsics
-INSN: ##unary-float-function < ##unary func ;
-INSN: ##binary-float-function < ##binary func ;
+PURE-INSN: ##unary-float-function
+def: dst/double-float-rep
+use: src/double-float-rep
+literal: func ;
+
+PURE-INSN: ##binary-float-function
+def: dst/double-float-rep
+use: src1/double-float-rep src2/double-float-rep
+literal: func ;
! Float/integer conversion
-INSN: ##float>integer < ##unary ;
-INSN: ##integer>float < ##unary ;
+PURE-INSN: ##float>integer
+def: dst/int-rep
+use: src/double-float-rep ;
+
+PURE-INSN: ##integer>float
+def: dst/double-float-rep
+use: src/int-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: ##copy
+def: dst
+use: src
+literal: rep ;
+
+PURE-INSN: ##unbox-float
+def: dst/double-float-rep
+use: src/int-rep ;
+
+PURE-INSN: ##unbox-any-c-ptr
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##box-float
+def: dst/int-rep
+use: src/double-float-rep
+temp: temp/int-rep ;
+
+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 ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
} 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: ##alien-float
+def: dst/double-float-rep
+use: src/int-rep ;
+
+INSN: ##alien-double
+def: dst/double-float-rep
+use: src/int-rep ;
-INSN: ##write-barrier < ##effect card# table ;
+INSN: ##set-alien-integer-1
+use: src/int-rep value/int-rep ;
-INSN: ##alien-global < ##flushable symbol library ;
+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/double-float-rep ;
+
+INSN: ##set-alien-double
+use: src/int-rep value/double-float-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 < ##conditional-branch ;
-INSN: ##compare-imm-branch src1 { src2 integer } 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-float-rep src2/double-float-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float
+def: dst/int-rep
+use: src1/double-float-rep src2/double-float-rep
+literal: cc
+temp: temp/int-rep ;
-INSN: ##compare < ##binary cc temp ;
-INSN: ##compare-imm < ##binary-imm cc temp ;
+! Overflowing arithmetic
+INSN: ##fixnum-add
+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-sub
+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: ##fixnum-mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-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-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 ;
IN: compiler.cfg.instructions.syntax
+SYMBOLS: def use temp literal constant ;
+
+TUPLE: insn-slot-spec type name rep ;
+
+: parse-insn-slot-spec ( type string -- spec )
+ over [ "Missing type" throw ] unless
+ "/" split1 dup [ "cpu.architecture" lookup ] when
+ 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 , ] ] 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 ;
! 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
: (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 ;
! 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 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
+
+: define-defs-vreg-rep-method ( insn -- )
+ [ \ defs-vreg-rep create-method ]
+ [ insn-def-slot dup [ rep>> ] when '[ drop _ ] ] bi
+ define ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ [ \ uses-vreg-reps create-method ]
+ [ insn-use-slots [ rep>> ] map '[ drop _ ] ] bi
+ define ;
+
+: define-temp-vreg-reps-method ( insn -- )
+ [ \ temp-vreg-reps create-method ]
+ [ insn-temp-slots [ rep>> ] map '[ drop _ ] ] bi
+ define ;
-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 ;
+PRIVATE>
+
+[
+ insn-classes get
+ [ { ##copy } diff [ define-defs-vreg-rep-method ] each ]
+ [ { ##copy ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ [ define-temp-vreg-reps-method ] each ]
+ tri
+] with-compilation-unit
+
+M: ##copy defs-vreg-rep rep>> ;
M: ##copy uses-vreg-reps rep>> 1array ;
-M: ##unary uses-vreg-reps drop { int-rep } ;
-M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
-M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
-M: ##binary-imm uses-vreg-reps drop { int-rep } ;
-M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##effect uses-vreg-reps drop { int-rep } ;
-M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
-M: ##slot-imm uses-vreg-reps drop { int-rep } ;
-M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
-M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##dispatch uses-vreg-reps drop { int-rep } ;
-M: ##alien-getter uses-vreg-reps drop { int-rep } ;
-M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: _dispatch uses-vreg-reps drop { int-rep } ;
-M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
-M: insn uses-vreg-reps drop f ;
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
##sar-imm
##min
##max
- ##fixnum-overflow
+ ##fixnum-add
+ ##fixnum-sub
+ ##fixnum-mul
##add-float
##sub-float
##mul-float
! 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 swap '[ _ cleave _ boa ] ;
+
+: 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
+ ] dip
+ '[ _ cleave _ execute ] ;
+
+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: ##integer>bignum %integer>bignum
+CODEGEN: ##bignum>integer %bignum>integer
+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: ##integer>float %integer>float
+CODEGEN: ##float>integer %float>integer
+CODEGEN: ##copy %copy
+CODEGEN: ##unbox-float %unbox-float
+CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
+CODEGEN: ##box-float %box-float
+CODEGEN: ##box-alien %box-alien
+CODEGEN: ##box-displaced-alien %box-displaced-alien
+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: ##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: ##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 ;
[ 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 ;
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: %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 ( -- )
"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 -- )
- negate-cc {
+: %boolean ( dst cc temp -- )
+ swap negate-cc {
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }
{ cc> [ \ BGT (%boolean) ] }
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
-M: ppc %compare (%compare) %boolean ;
-M: ppc %compare-imm (%compare-imm) %boolean ;
-M: ppc %compare-float (%compare-float) %boolean ;
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+M: ppc %compare-float [ (%compare-float) ] 2dip %boolean ;
: %branch ( label cc -- )
{
{ cc/= [ BNE ] }
} case ;
-M: ppc %compare-branch (%compare) %branch ;
-M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M: ppc %compare-float-branch (%compare-float) %branch ;
+M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
+M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
+M: ppc %compare-float-branch [ (%compare-float) ] 2dip %branch ;
: load-from-frame ( dst n rep -- )
{
{ 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 ;
"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
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M: x86 %compare ( dst temp cc src1 src2 -- )
- CMP {
+M: x86 %compare ( dst src1 src2 cc temp -- )
+ [ CMP ] 2dip swap {
{ cc< [ \ CMOVL %boolean ] }
{ cc<= [ \ CMOVLE %boolean ] }
{ cc> [ \ CMOVG %boolean ] }
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-imm ( dst temp cc src1 src2 -- )
+M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
-M: x86 %compare-float ( dst temp cc src1 src2 -- )
- UCOMISD {
+M: x86 %compare-float ( dst src1 src2 cc temp -- )
+ [ UCOMISD ] 2dip swap {
{ cc< [ \ CMOVB %boolean ] }
{ cc<= [ \ CMOVBE %boolean ] }
{ cc> [ \ CMOVA %boolean ] }
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-branch ( label cc src1 src2 -- )
- CMP {
+M: x86 %compare-branch ( label src1 src2 cc -- )
+ [ CMP ] dip {
{ cc< [ JL ] }
{ cc<= [ JLE ] }
{ cc> [ JG ] }
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
-M: x86 %compare-float-branch ( label cc src1 src2 -- )
- UCOMISD {
+M: x86 %compare-float-branch ( label src1 src2 cc -- )
+ [ UCOMISD ] dip {
{ cc< [ JB ] }
{ cc<= [ JBE ] }
{ cc> [ JA ] }
{ cc/= [ JNE ] }
} 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 ;
projects / factor.git / commitdiff