diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index a9f3f2eaa9..4ac25a3c30 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -4,6 +4,8 @@ words sequences.private fry prettyprint alien math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger ; +\ build-cfg must-infer + ! Just ensure that various CFGs build correctly. { [ ] diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e5f91d19df..7fd65fb05e 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -2,24 +2,23 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators hashtables kernel math fry namespaces make sequences words byte-arrays -locals layouts alien.c-types alien.structs -stack-checker.inlining -cpu.architecture -compiler.intrinsics +layouts alien.c-types alien.structs +stack-checker.inlining cpu.architecture compiler.tree compiler.tree.builder compiler.tree.combinators compiler.tree.propagation.info compiler.cfg -compiler.cfg.stacks -compiler.cfg.templates compiler.cfg.iterator -compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.builder.hats +compiler.cfg.builder.calls +compiler.cfg.builder.stacks compiler.alien ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG (not quite SSA yet) IR. +! Convert tree SSA IR to CFG SSA IR. : set-basic-block ( basic-block -- ) [ basic-block set ] [ instructions>> building set ] bi ; @@ -93,12 +92,6 @@ GENERIC: emit-node ( node -- next ) ] with-variable ] keep ; -SYMBOL: +intrinsics+ -SYMBOL: +if-intrinsics+ - -: if-intrinsics ( #call -- quot ) - word>> +if-intrinsics+ word-prop ; - : local-recursive-call ( basic-block -- next ) ##branch basic-block get successors>> push @@ -131,22 +124,22 @@ M: #recursive emit-node dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; ! #if -: emit-branch ( obj quot -- final-bb ) - '[ +: emit-branch ( obj -- final-bb ) + [ begin-basic-block copy-phantoms - @ + emit-nodes basic-block get dup [ ##branch ] when ] with-scope ; -: emit-branches ( seq quot -- ) - '[ _ emit-branch ] map +: emit-if ( node -- ) + children>> [ emit-branch ] map end-basic-block begin-basic-block basic-block get '[ [ _ swap successors>> push ] when* ] each init-phantoms ; -: emit-if ( node -- next ) - children>> [ emit-nodes ] emit-branches ; +: ##branch-t ( vreg -- ) + \ f tag-number cc/= ##binary-imm-branch ; M: #if emit-node phantom-pop ##branch-t emit-if iterate-next ; @@ -194,100 +187,16 @@ M: #dispatch emit-node ] if ; ! #call -: define-intrinsics ( word intrinsics -- ) - +intrinsics+ set-word-prop ; - -: define-intrinsic ( word quot assoc -- ) - 2array 1array define-intrinsics ; - -: define-if-intrinsics ( word intrinsics -- ) - [ template new swap >>input ] assoc-map - +if-intrinsics+ set-word-prop ; - -: define-if-intrinsic ( word quot inputs -- ) - 2array 1array define-if-intrinsics ; - -: find-intrinsic ( #call -- pair/f ) - word>> +intrinsics+ word-prop find-template ; - -: find-boolean-intrinsic ( #call -- pair/f ) - word>> +if-intrinsics+ word-prop find-template ; - -: find-if-intrinsic ( #call -- pair/f ) - node@ { - { [ dup length 2 < ] [ 2drop f ] } - { [ dup second #if? ] [ drop find-boolean-intrinsic ] } - [ 2drop f ] - } cond ; - -: do-if-intrinsic ( pair -- next ) - [ ##if-intrinsic ] apply-template skip-next emit-if - iterate-next ; - -: do-boolean-intrinsic ( pair -- next ) - [ ##if-intrinsic ] apply-template - { t f } [ - phantom-push finalize-phantoms - ] emit-branches - iterate-next ; - -: do-intrinsic ( pair -- next ) - [ ##intrinsic ] apply-template iterate-next ; - -: setup-value-classes ( #call -- ) - node-input-infos [ class>> ] map set-value-classes ; - -{ - (tuple) (array) (byte-array) - (complex) (ratio) (wrapper) - (write-barrier) -} [ t "intrinsic" set-word-prop ] each - -: allot-size ( -- n ) - 1 phantom-datastack get phantom-input first value>> ; - -:: emit-allot ( size type tag -- ) - int-regs next-vreg - dup fresh-object - dup size type tag int-regs next-vreg ##allot - type tagged boa phantom-push ; - -: emit-write-barrier ( -- ) - phantom-pop dup fresh-object? [ drop ] [ - int-regs next-vreg - int-regs next-vreg - ##write-barrier - ] if ; - -: emit-intrinsic ( word -- next ) - { - { \ (tuple) [ allot-size 2 + cells tuple tuple emit-allot ] } - { \ (array) [ allot-size 2 + cells array object emit-allot ] } - { \ (byte-array) [ allot-size 2 cells + byte-array object emit-allot ] } - { \ (complex) [ 3 cells complex complex emit-allot ] } - { \ (ratio) [ 3 cells ratio ratio emit-allot ] } - { \ (wrapper) [ 2 cells wrapper object emit-allot ] } - { \ (write-barrier) [ emit-write-barrier ] } - } case - iterate-next ; - M: #call emit-node - dup setup-value-classes - dup find-if-intrinsic [ do-if-intrinsic ] [ - dup find-boolean-intrinsic [ do-boolean-intrinsic ] [ - dup find-intrinsic [ do-intrinsic ] [ - word>> dup "intrinsic" word-prop - [ emit-intrinsic ] [ emit-call ] if - ] ?if - ] ?if - ] ?if ; + dup word>> dup "intrinsic" word-prop + [ emit-intrinsic iterate-next ] [ nip emit-call ] if ; ! #call-recursive M: #call-recursive emit-node label>> id>> emit-call ; ! #push M: #push emit-node - literal>> phantom-push iterate-next ; + literal>> ^^load-literal phantom-push iterate-next ; ! #shuffle M: #shuffle emit-node diff --git a/basis/compiler/cfg/builder/calls/calls.factor b/basis/compiler/cfg/builder/calls/calls.factor new file mode 100644 index 0000000000..86ebdf575b --- /dev/null +++ b/basis/compiler/cfg/builder/calls/calls.factor @@ -0,0 +1,360 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: qualified kernel words sequences layouts namespaces +accessors fry arrays byte-arrays locals math combinators alien +classes.algebra cpu.architecture compiler.tree.propagation.info +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.builder.hats +compiler.cfg.builder.stacks ; +QUALIFIED: compiler.intrinsics +QUALIFIED: kernel.private +QUALIFIED: slots.private +QUALIFIED: math.private +QUALIFIED: alien.accessors +IN: compiler.cfg.builder.calls + +{ + kernel.private:tag + math.private:fixnum+fast + math.private:fixnum-fast + math.private:fixnum-bitand + math.private:fixnum-bitor + math.private:fixnum-bitxor + math.private:fixnum-shift-fast + math.private:fixnum-bitnot + math.private:fixnum*fast + math.private:fixnum< + math.private:fixnum<= + math.private:fixnum>= + math.private:fixnum> + math.private:bignum>fixnum + math.private:fixnum>bignum + eq? + compiler.intrinsics:(slot) + compiler.intrinsics:(set-slot) + compiler.intrinsics:(tuple) + compiler.intrinsics:(array) + compiler.intrinsics:(byte-array) + compiler.intrinsics:(complex) + compiler.intrinsics:(ratio) + compiler.intrinsics:(wrapper) + compiler.intrinsics:(write-barrier) + alien.accessors:alien-unsigned-1 + alien.accessors:set-alien-unsigned-1 + alien.accessors:alien-signed-1 + alien.accessors:set-alien-signed-1 + alien.accessors:alien-unsigned-2 + alien.accessors:set-alien-unsigned-2 + alien.accessors:alien-signed-2 + alien.accessors:set-alien-signed-2 + alien.accessors:alien-cell + alien.accessors:set-alien-cell +} [ t "intrinsic" set-word-prop ] each + +: enable-alien-4-intrinsics ( -- ) + { + alien.accessors:alien-unsigned-4 + alien.accessors:set-alien-unsigned-4 + alien.accessors:alien-signed-4 + alien.accessors:set-alien-signed-4 + } [ t "intrinsic" set-word-prop ] each ; + +: enable-float-intrinsics ( -- ) + { + math.private:float+ + math.private:float- + math.private:float* + math.private:float/f + math.private:fixnum>float + math.private:float>fixnum + alien.accessors:alien-float + alien.accessors:set-alien-float + alien.accessors:alien-double + alien.accessors:set-alien-double + } [ t "intrinsic" set-word-prop ] each ; + +: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; + +: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; + +: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; + +: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; + +: emit-tag ( -- ) + phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ; + +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; + +: (emit-slot) ( infos -- dst ) + [ 2phantom-pop ] [ third literal>> ] bi* + ^^slot ; + +: (emit-slot-imm) ( infos -- dst ) + 1 phantom-drop + [ phantom-pop ^^offset>slot ] + [ [ second literal>> ] [ third literal>> ] bi ] bi* + ^^slot-imm ; + +: value-info-small-tagged? ( value-info -- ? ) + dup literal?>> [ literal>> small-tagged? ] [ drop f ] if ; + +: emit-slot ( node -- ) + node-input-infos + dup second value-info-small-tagged? + [ (emit-slot-imm) ] [ (emit-slot) ] if + phantom-push ; + +: (emit-set-slot) ( infos -- ) + [ 3phantom-pop ] [ fourth literal>> ] bi* + ##set-slot ; + +: (emit-set-slot-imm) ( infos -- ) + 1 phantom-drop + [ 2phantom-pop ^^offset>slot ] + [ [ third literal>> ] [ fourth literal>> ] bi ] bi* + ##set-slot-imm ; + +: emit-set-slot ( node -- ) + 1 phantom-drop + node-input-infos + dup third value-info-small-tagged? + [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ; + +: (emit-fixnum-imm-op) ( infos insn -- dst ) + 1 phantom-drop + [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri* + call ; inline + +: (emit-fixnum-op) ( insn -- dst ) + [ 2phantom-pop ] dip call ; inline + +:: emit-fixnum-op ( node insn imm-insn -- ) + [let | infos [ node node-input-infos ] | + infos second value-info-small-tagged? + [ infos imm-insn (emit-fixnum-imm-op) ] + [ insn (emit-fixnum-op) ] + if + ] ; inline + +: emit-primitive ( node -- ) + word>> ##simple-stack-frame ##call ; + +: emit-fixnum-shift-fast ( node -- ) + dup node-input-infos dup second value-info-small-tagged? [ + nip + [ 1 phantom-drop phantom-pop ] dip + second literal>> dup sgn { + { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } + { 0 [ drop ] } + { 1 [ ^^shl-imm ] } + } case + phantom-push + ] [ drop emit-primitive ] if ; + +: emit-fixnum-bitnot ( -- ) + phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ; + +: (emit-fixnum*fast) ( -- dst ) + 2phantom-pop ^^untag-fixnum ^^mul ; + +: (emit-fixnum*fast-imm) ( infos -- dst ) + 1 phantom-drop + [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ; + +: emit-fixnum*fast ( node -- ) + node-input-infos + dup second value-info-small-tagged? + [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if + phantom-push ; + +: emit-fixnum-comparison ( node cc -- ) + [ '[ _ ##boolean ] ] [ '[ _ ##boolean-imm ] ] bi + emit-fixnum-op ; + +: emit-bignum>fixnum ( -- ) + phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ; + +: emit-fixnum>bignum ( -- ) + phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ; + +: emit-float-op ( insn -- ) + [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float ; inline + +: emit-float-comparison ( cc -- ) + '[ _ ##boolean ] emit-float-op ; + +: emit-float>fixnum ( -- ) + phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ; + +: emit-fixnum>float ( -- ) + phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ; + +: pop-literal ( node -- n ) + 1 phantom-drop dup in-d>> first node-value-info literal>> ; + +: emit-allot ( size type tag -- ) + ^^allot [ fresh-object ] [ phantom-push ] bi ; + +: emit-write-barrier ( -- ) + phantom-pop dup fresh-object? [ drop ] [ ^^write-barrier ] if ; + +: (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) + 1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; + +: (prepare-alien-accessor) ( class -- offset-vreg ) + [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; + +: prepare-alien-accessor ( infos -- offset-vreg ) + [ second class>> ] [ first ] bi + dup value-info-small-tagged? [ + 1 phantom-drop + 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 ] + [ node emit-primitive ] + if + ] ; inline + +: inline-alien-getter? ( infos -- ? ) + [ first class>> c-ptr class<= ] + [ second class>> fixnum class<= ] + bi and ; + +: inline-alien-getter ( node quot -- ) + '[ @ phantom-push ] + [ inline-alien-getter? ] inline-alien ; inline + +: inline-alien-setter? ( infos class -- ? ) + '[ first class>> _ class<= ] + [ second class>> c-ptr class<= ] + [ third class>> fixnum class<= ] + tri and and ; + +: inline-alien-integer-setter ( node quot -- ) + '[ phantom-pop ^^untag-fixnum @ ] + [ fixnum inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-cell-setter ( node quot -- ) + [ dup node-input-infos first class>> ] dip + '[ phantom-pop _ ^^unbox-c-ptr @ ] + [ pinned-c-ptr inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-float-setter ( node quot -- ) + '[ phantom-pop ^^unbox-float @ ] + [ float inline-alien-setter? ] + inline-alien ; inline + +: emit-alien-unsigned-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-unsigned-1 ] } + { 2 [ ^^alien-unsigned-2 ] } + { 4 [ ^^alien-unsigned-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-signed-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-signed-1 ] } + { 2 [ ^^alien-signed-2 ] } + { 4 [ ^^alien-signed-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-integer-setter ( node n -- ) + '[ + _ { + { 1 [ ##set-alien-integer-1 ] } + { 2 [ ##set-alien-integer-2 ] } + { 4 [ ##set-alien-integer-4 ] } + } case + ] inline-alien-integer-setter ; + +: emit-alien-cell-getter ( node -- ) + [ ^^alien-cell ^^box-alien ] inline-alien-getter ; + +: emit-alien-cell-setter ( node -- ) + [ ##set-alien-cell ] inline-alien-cell-setter ; + +: emit-alien-float-getter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ^^alien-float ] } + { double-float-regs [ ^^alien-double ] } + } case ^^box-float + ] inline-alien-getter ; + +: emit-alien-float-setter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ##set-alien-float ] } + { double-float-regs [ ##set-alien-double ] } + } case + ] inline-alien-float-setter ; + +: emit-intrinsic ( node word -- ) + { + { \ kernel.private:tag [ drop emit-tag ] } + { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } + { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } + { \ math.private:fixnum*fast [ emit-fixnum*fast ] } + { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } + { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } + { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } + { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } + { \ eq? [ cc= emit-fixnum-comparison ] } + { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } + { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } + { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } + { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } + { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } + { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } + { \ math.private:float< [ drop cc< emit-float-comparison ] } + { \ math.private:float<= [ drop cc<= emit-float-comparison ] } + { \ math.private:float>= [ drop cc>= emit-float-comparison ] } + { \ math.private:float> [ drop cc> emit-float-comparison ] } + { \ math.private:float= [ drop cc> emit-float-comparison ] } + { \ math.private:float>fixnum [ drop emit-float>fixnum ] } + { \ math.private:fixnum>float [ drop emit-fixnum>float ] } + { \ compiler.intrinsics:(slot) [ emit-slot ] } + { \ compiler.intrinsics:(set-slot) [ emit-set-slot ] } + { \ compiler.intrinsics:(tuple) [ pop-literal 2 + cells tuple tuple emit-allot ] } + { \ compiler.intrinsics:(array) [ pop-literal 2 + cells array object emit-allot ] } + { \ compiler.intrinsics:(byte-array) [ pop-literal 2 cells + byte-array object emit-allot ] } + { \ compiler.intrinsics:(complex) [ drop 3 cells complex complex emit-allot ] } + { \ compiler.intrinsics:(ratio) [ drop 3 cells ratio ratio emit-allot ] } + { \ compiler.intrinsics:(wrapper) [ drop 2 cells wrapper object emit-allot ] } + { \ compiler.intrinsics:(write-barrier) [ drop emit-write-barrier ] } + { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } + { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } + { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] } + { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] } + } case ; diff --git a/basis/compiler/cfg/builder/hats/hats.factor b/basis/compiler/cfg/builder/hats/hats.factor new file mode 100644 index 0000000000..4ac7f92ea3 --- /dev/null +++ b/basis/compiler/cfg/builder/hats/hats.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel cpu.architecture compiler.cfg.registers +compiler.cfg.instructions ; +IN: compiler.cfg.builder.hats + +: i int-regs next-vreg ; inline +: ^^i i dup ; inline +: ^^i1 [ ^^i ] dip ; inline +: ^^i2 [ ^^i ] 2dip ; inline +: ^^i3 [ ^^i ] 3dip ; inline + +: d double-float-regs next-vreg ; inline +: ^^d d dup ; inline +: ^^d1 [ ^^d ] dip ; inline +: ^^d2 [ ^^d ] 2dip ; inline +: ^^d3 [ ^^d ] 3dip ; inline + +: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline +: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline +: ^^slot ( obj slot tag -- dst ) ^^i3 ##slot ; inline +: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline +: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline +: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline +: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline +: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline +: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline +: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline +: ^^and ( input mask -- output ) ^^i2 ##and ; inline +: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline +: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline +: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline +: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline +: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline +: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline +: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline +: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline +: ^^not ( src -- dst ) ^^i1 ##not ; inline +: ^^bignum>integer ( src -- dst ) ^^i1 ##bignum>integer ; inline +: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline +: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline +: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline +: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline +: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline +: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline +: ^^integer>float ( src -- dst ) ^^d1 i ##integer>float ; inline +: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline +: ^^write-barrier ( src -- ) i i ##write-barrier ; inline +: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline +: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline +: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline +: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline +: ^^unbox-c-ptr ( src class -- dst ) ^^i2 ##unbox-c-ptr ; +: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline +: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline +: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline +: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline +: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline +: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-3 ; inline +: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline +: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline +: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline diff --git a/basis/compiler/cfg/stacks/authors.txt b/basis/compiler/cfg/builder/stacks/authors.txt similarity index 100% rename from basis/compiler/cfg/stacks/authors.txt rename to basis/compiler/cfg/builder/stacks/authors.txt diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/builder/stacks/stacks.factor similarity index 52% rename from basis/compiler/cfg/stacks/stacks.factor rename to basis/compiler/cfg/builder/stacks/stacks.factor index 8d0537c64d..e1119e18d6 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/builder/stacks/stacks.factor @@ -3,9 +3,11 @@ USING: arrays assocs classes classes.private classes.algebra combinators hashtables kernel layouts math fry namespaces quotations sequences system vectors words effects alien -byte-arrays accessors sets math.order cpu.architecture -compiler.cfg.instructions compiler.cfg.registers ; -IN: compiler.cfg.stacks +byte-arrays accessors sets math.order +combinators.short-circuit cpu.architecture +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.builder.hats ; +IN: compiler.cfg.builder.stacks ! Converting stack operations into register operations, while ! doing a bit of optimization along the way. @@ -13,75 +15,6 @@ PREDICATE: small-slot < integer cells small-enough? ; PREDICATE: small-tagged < integer tag-fixnum small-enough? ; -! Value protocol -GENERIC: move-spec ( obj -- spec ) -GENERIC: live-loc? ( actual current -- ? ) -GENERIC: lazy-store ( dst src -- ) - -! This will be a multimethod soon -DEFER: ##move - -PRIVATE> - -! Default implementation -M: value live-loc? 2drop f ; -M: value lazy-store 2drop ; - -M: vreg move-spec reg-class>> move-spec ; -M: vreg value-class* reg-class>> value-class* ; - -M: int-regs move-spec drop f ; -M: int-regs value-class* drop object ; - -M: float-regs move-spec drop float ; -M: float-regs value-class* drop float ; - -M: ds-loc live-loc? - over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; - -M: rs-loc live-loc? - over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; - -M: loc value-class* class>> ; -M: loc set-value-class (>>class) ; -M: loc move-spec drop loc ; - -M: f move-spec drop loc ; -M: f value-class* ; - -M: tagged move-spec drop f ; - -M: unboxed-alien move-spec class ; - -M: unboxed-byte-array move-spec class ; - -M: unboxed-f move-spec class ; - -M: unboxed-c-ptr move-spec class ; - -M: constant move-spec class ; - -! Moving values between locations and registers -: ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ; - -: ##unbox-c-ptr ( dst src -- ) - dup value-class { - { [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] } - { [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] } - { [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] } - [ drop [ >vreg ] bi@ ##unbox-any-c-ptr ] - } cond ; inline - -: ##move-via-temp ( dst src -- ) - #! For many transfers, such as loc to unboxed-alien, we - #! don't have an intrinsic, so we transfer the source to - #! temp then temp to the destination. - int-regs next-vreg [ over ##move value-class ] keep - tagged new - swap >>vreg - swap >>class - ##move ; - ! Operands holding pointers to freshly-allocated objects which ! are guaranteed to be in the nursery SYMBOL: fresh-objects @@ -90,34 +23,6 @@ SYMBOL: fresh-objects : fresh-object? ( vreg -- ? ) fresh-objects get memq? ; -: ##move ( dst src -- ) - 2dup [ move-spec ] bi@ 2array { - { { f f } [ [ >vreg ] bi@ ##copy ] } - { { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] } - { { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] } - { { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] } - { { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] } - { { float float } [ [ >vreg ] bi@ ##copy-float ] } - - { { f unboxed-c-ptr } [ ##move-bug ] } - { { f unboxed-byte-array } [ ##move-bug ] } - - { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] } - - { { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] } - { { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] } - { { f loc } [ [ >vreg ] dip ##peek ] } - - { { float f } [ [ >vreg ] bi@ ##unbox-float ] } - { { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] } - { { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] } - { { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] } - { { unboxed-c-ptr f } [ ##unbox-c-ptr ] } - { { loc f } [ >vreg swap ##replace ] } - - [ drop ##move-via-temp ] - } case ; - ! A compile-time stack TUPLE: phantom-stack height stack ; @@ -204,42 +109,13 @@ M: phantom-retainstack finalize-height : finalize-heights ( -- ) [ finalize-height ] each-phantom ; -: reg-spec>class ( spec -- class ) - float eq? double-float-regs int-regs ? ; +GENERIC: lazy-load ( loc/vreg -- vreg ) +M: loc lazy-load ^^peek ; +M: vreg lazy-load ; -: alloc-vreg ( spec -- reg ) - [ reg-spec>class next-vreg ] keep { - { f [ ] } - { unboxed-alien [ ] } - { unboxed-byte-array [ ] } - { unboxed-f [ ] } - { unboxed-c-ptr [ ] } - [ drop ] - } case ; - -: alloc-vreg-for ( value spec -- vreg ) - alloc-vreg swap value-class - over tagged? [ >>class ] [ drop ] if ; - -: (eager-load) ( value spec -- vreg ) - [ alloc-vreg-for ] [ drop ] 2bi - [ ##move ] [ drop >vreg ] 2bi ; - -: compatible? ( value spec -- ? ) - >r move-spec r> { - { [ 2dup = ] [ t ] } - { [ dup unboxed-c-ptr eq? ] [ - over { unboxed-byte-array unboxed-alien } member? - ] } - [ f ] - } cond 2nip ; - -: (lazy-load) ( value spec -- value ) - { - { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] } - { [ 2dup compatible? ] [ drop >vreg ] } - [ (eager-load) ] - } cond ; +GENERIC: live-loc? ( actual current -- ? ) +M: vreg live-loc? 2drop f ; +M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ; : (live-locs) ( phantom -- seq ) #! Discard locs which haven't moved @@ -250,19 +126,26 @@ M: phantom-retainstack finalize-height : live-locs ( -- seq ) [ (live-locs) ] each-phantom append prune ; +GENERIC: lazy-store ( dst src -- ) + +M: vreg lazy-store 2drop ; + M: loc lazy-store - 2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ; + 2dup live-loc? [ + \ live-locs get at swap ##replace + ] [ 2drop ] if ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. - live-locs [ dup f (lazy-load) ] H{ } map>assoc + live-locs [ dup lazy-load ] H{ } map>assoc dup assoc-empty? [ drop ] [ - "live-locs" set [ lazy-store ] each-loc + \ live-locs set + [ lazy-store ] each-loc ] if ; : finalize-vregs ( -- ) #! Store any vregs to their final stack locations. - [ dup loc? [ 2drop ] [ ##move ] if ] each-loc ; + [ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ; : clear-phantoms ( -- ) [ stack>> delete-all ] each-phantom ; @@ -271,11 +154,6 @@ M: loc lazy-store finalize-locs finalize-vregs clear-phantoms ; ! Loading stacks to vregs -: set-value-classes ( classes -- ) - phantom-datastack get - over length over add-locs - stack>> [ set-value-class ] 2reverse-each ; - : finalize-phantoms ( -- ) #! Commit all deferred stacking shuffling, and ensure the #! in-memory data and retain stacks are up to date with @@ -318,5 +196,14 @@ M: loc lazy-store : phantom-rdrop ( n -- ) phantom-retainstack get phantom-input drop ; +: phantom-load ( n -- vreg ) + phantom-datastack get phantom-input [ lazy-load ] map ; + : phantom-pop ( -- vreg ) - 1 phantom-datastack get phantom-input first f (lazy-load) ; + 1 phantom-load first ; + +: 2phantom-pop ( -- vreg1 vreg2 ) + 2 phantom-load first2 ; + +: 3phantom-pop ( -- vreg1 vreg2 vreg3 ) + 3 phantom-load first3 ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6665564c91..294238fbbf 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words sequences quotations namespaces io -accessors prettyprint prettyprint.config +classes.tuple accessors prettyprint prettyprint.config compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.linearization compiler.cfg.stack-frame compiler.cfg.linear-scan ; @@ -15,16 +15,25 @@ M: callable test-cfg M: word test-cfg [ build-tree-from-word nip optimize-tree ] keep build-cfg ; +SYMBOL: allocate-registers? + : test-mr ( quot -- mrs ) - test-cfg [ build-mr linear-scan build-stack-frame ] map ; + test-cfg [ + build-mr + allocate-registers? get + [ linear-scan build-stack-frame ] when + ] map ; + +: insn. ( insn -- ) + tuple>array allocate-registers? get [ but-last ] unless + [ pprint bl ] each nl ; : mr. ( mrs -- ) [ - boa-tuples? on "=== word: " write dup word>> pprint ", label: " write dup label>> pprint nl nl - instructions>> . + instructions>> [ insn. ] each nl ] each ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor new file mode 100644 index 0000000000..93232579de --- /dev/null +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel compiler.cfg.instructions +compiler.cfg.instructions.syntax ; +IN: compiler.cfg.def-use + +GENERIC: defs-vregs ( insn -- seq ) +GENERIC: uses-vregs ( insn -- seq ) + +: allot-defs-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ; +M: ##flushable defs-vregs dst>> 1array ; +M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; +M: ##boxer defs-vregs allot-defs-vregs ; +M: ##allot defs-vregs allot-defs-vregs ; +M: ##dispatch defs-vregs temp>> 1array ; +M: insn defs-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: ##binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: ##binary-imm-branch uses-vregs src1>> 1array ; +M: ##dispatch uses-vregs src>> 1array ; +M: _binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: _binary-imm-branch uses-vregs src1>> 1array ; +M: insn uses-vregs drop f ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 689650f0a4..368460b920 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -1,19 +1,49 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors arrays kernel sequences namespaces words -math compiler.cfg.registers compiler.cfg.instructions.syntax ; +math math.order layouts classes.algebra alien byte-arrays +combinators compiler.cfg.registers +compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions ! Virtual CPU instructions, used by CFG and machine IRs -TUPLE: ##cond-branch < insn { src vreg } ; -TUPLE: ##unary < insn { dst vreg } { src vreg } ; -TUPLE: ##nullary < insn { dst vreg } ; +! Instruction with no side effects; if 'out' is never read, we +! can eliminate it. +TUPLE: ##flushable < insn { dst vreg } ; + +! Instruction which is referentially transparent; we can replace +! repeated computation with a reference to a previous value +TUPLE: ##pure < ##flushable ; + +TUPLE: ##unary < ##pure { src vreg } ; +TUPLE: ##boxer < ##unary { temp vreg } ; +TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ; +TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ; +TUPLE: ##commutative < ##binary ; + +! Instruction only used for its side effect, produces no values +TUPLE: ##effect < insn { src vreg } ; + +! Read/write ops: candidates for alias analysis +TUPLE: ##read < ##flushable ; +TUPLE: ##write < ##effect ; + +TUPLE: ##alien-getter < ##read { src vreg } ; +TUPLE: ##alien-setter < ##effect { value vreg } ; ! Stack operations -INSN: ##load-literal < ##nullary obj ; -INSN: ##peek < ##nullary { loc loc } ; -INSN: ##replace { src vreg } { loc loc } ; +INSN: ##load-immediate < ##pure { val integer } ; +INSN: ##load-indirect < ##pure obj ; + +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-indirect ; + +INSN: ##peek < ##read { loc loc } ; +INSN: ##replace < ##write { loc loc } ; INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; @@ -30,12 +60,48 @@ INSN: ##call word ; INSN: ##jump word ; INSN: ##return ; -INSN: ##intrinsic quot defs-vregs uses-vregs ; - ! Jump tables INSN: ##dispatch src temp ; INSN: ##dispatch-label label ; +! Slot access +INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } ; +INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ; +INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } ; +INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ; + +! Integer arithmetic +INSN: ##add < ##commutative ; +INSN: ##add-imm < ##binary-imm ; +INSN: ##sub < ##binary ; +INSN: ##sub-imm < ##binary-imm ; +INSN: ##mul < ##commutative ; +INSN: ##mul-imm < ##binary-imm ; +INSN: ##and < ##commutative ; +INSN: ##and-imm < ##binary-imm ; +INSN: ##or < ##commutative ; +INSN: ##or-imm < ##binary-imm ; +INSN: ##xor < ##commutative ; +INSN: ##xor-imm < ##binary-imm ; +INSN: ##shl-imm < ##binary-imm ; +INSN: ##shr-imm < ##binary-imm ; +INSN: ##sar-imm < ##binary-imm ; +INSN: ##not < ##unary ; + +! Bignum/integer conversion +INSN: ##integer>bignum < ##boxer ; +INSN: ##bignum>integer < ##unary ; + +! Float arithmetic +INSN: ##add-float < ##commutative ; +INSN: ##sub-float < ##binary ; +INSN: ##mul-float < ##commutative ; +INSN: ##div-float < ##binary ; + +! Float/integer conversion +INSN: ##float>integer < ##unary ; +INSN: ##integer>float < ##unary ; + ! Boxing and unboxing INSN: ##copy < ##unary ; INSN: ##copy-float < ##unary ; @@ -44,12 +110,38 @@ INSN: ##unbox-f < ##unary ; INSN: ##unbox-alien < ##unary ; INSN: ##unbox-byte-array < ##unary ; INSN: ##unbox-any-c-ptr < ##unary ; -INSN: ##box-float < ##unary { temp vreg } ; -INSN: ##box-alien < ##unary { temp vreg } ; +INSN: ##box-float < ##boxer ; +INSN: ##box-alien < ##boxer ; + +: ##unbox-c-ptr ( dst src class -- ) + { + { [ dup \ f class<= ] [ drop ##unbox-f ] } + { [ dup simple-alien class<= ] [ drop ##unbox-alien ] } + { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] } + [ drop ##unbox-any-c-ptr ] + } cond ; inline + +! 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-3 < ##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-getter ; +INSN: ##set-alien-float < ##alien-setter ; +INSN: ##set-alien-double < ##alien-setter ; ! Memory allocation -INSN: ##allot < ##nullary size type tag { temp vreg } ; -INSN: ##write-barrier { src vreg } card# table ; +INSN: ##allot < ##flushable size type tag { temp vreg } ; +INSN: ##write-barrier < ##effect card# table ; INSN: ##gc ; ! FFI @@ -58,54 +150,35 @@ INSN: ##alien-indirect params ; INSN: ##alien-callback params ; INSN: ##callback-return params ; -GENERIC: defs-vregs ( insn -- seq ) -GENERIC: uses-vregs ( insn -- seq ) - -M: ##nullary defs-vregs dst>> 1array ; -M: ##unary defs-vregs dst>> 1array ; -M: ##write-barrier defs-vregs - [ card#>> ] [ table>> ] bi 2array ; - -: allot-defs-vregs ( insn -- seq ) - [ dst>> ] [ temp>> ] bi 2array ; - -M: ##box-float defs-vregs allot-defs-vregs ; -M: ##box-alien defs-vregs allot-defs-vregs ; -M: ##allot defs-vregs allot-defs-vregs ; -M: ##dispatch defs-vregs temp>> 1array ; -M: insn defs-vregs drop f ; - -M: ##replace uses-vregs src>> 1array ; -M: ##unary uses-vregs src>> 1array ; -M: ##write-barrier uses-vregs src>> 1array ; -M: ##dispatch uses-vregs src>> 1array ; -M: insn uses-vregs drop f ; - -: intrinsic-vregs ( assoc -- seq' ) - [ nip dup vreg? swap and ] { } assoc>map sift ; - -: intrinsic-defs-vregs ( insn -- seq ) - defs-vregs>> intrinsic-vregs ; - -: intrinsic-uses-vregs ( insn -- seq ) - uses-vregs>> intrinsic-vregs ; - -M: ##intrinsic defs-vregs intrinsic-defs-vregs ; -M: ##intrinsic uses-vregs intrinsic-uses-vregs ; - ! Instructions used by CFG IR only. INSN: ##prologue ; INSN: ##epilogue ; INSN: ##branch ; -INSN: ##branch-f < ##cond-branch ; -INSN: ##branch-t < ##cond-branch ; -INSN: ##if-intrinsic quot defs-vregs uses-vregs ; -M: ##cond-branch uses-vregs src>> 1array ; +! Condition codes +SYMBOL: cc< +SYMBOL: cc<= +SYMBOL: cc= +SYMBOL: cc> +SYMBOL: cc>= +SYMBOL: cc/= -M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ; -M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ; +: evaluate-cc ( result cc -- ? ) + H{ + { cc< { +lt+ } } + { cc<= { +lt+ +eq+ } } + { cc= { +eq+ } } + { cc>= { +eq+ +gt+ } } + { cc> { +gt+ } } + { cc/= { +lt+ +gt+ } } + } at memq? ; + +INSN: ##binary-branch { src1 vreg } { src2 vreg } cc ; +INSN: ##binary-imm-branch { src1 vreg } { src2 integer } cc ; + +INSN: ##boolean < ##binary cc ; +INSN: ##boolean-imm < ##binary-imm cc ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; @@ -113,17 +186,10 @@ INSN: _epilogue stack-frame ; INSN: _label id ; -TUPLE: _cond-branch < insn { src vreg } label ; - INSN: _branch label ; -INSN: _branch-f < _cond-branch ; -INSN: _branch-t < _cond-branch ; -INSN: _if-intrinsic label quot defs-vregs uses-vregs ; -M: _cond-branch uses-vregs src>> 1array ; - -M: _if-intrinsic defs-vregs intrinsic-defs-vregs ; -M: _if-intrinsic uses-vregs intrinsic-uses-vregs ; +INSN: _binary-branch label { src1 vreg } { src2 vreg } cc ; +INSN: _binary-imm-branch label { src1 vreg } { src2 integer } cc ; ! These instructions operate on machine registers and not ! virtual registers diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 876bb6ba6c..2d8ad8c214 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -3,6 +3,7 @@ USING: accessors kernel math assocs namespaces sequences heaps fry make combinators cpu.architecture +compiler.cfg.def-use compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 3ab7e03783..54cead850c 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math fry -compiler.cfg.instructions compiler.cfg.registers ; +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.def-use ; IN: compiler.cfg.linear-scan.live-intervals TUPLE: live-interval diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 24730cd17f..c8e4b734d8 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -40,21 +40,14 @@ M: ##branch linearize-insn : conditional ( basic-block -- basic-block successor1 label2 ) dup successors>> first2 swap number>> ; inline -: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 ) - [ conditional ] [ src>> ] bi* swap ; inline +: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) + [ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline -M: ##branch-f linearize-insn - boolean-conditional _branch-f emit-branch ; +M: ##binary-branch linearize-insn + binary-conditional _binary-branch emit-branch ; -M: ##branch-t linearize-insn - boolean-conditional _branch-t emit-branch ; - -: >intrinsic< ( insn -- quot defs uses ) - [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ; - -M: ##if-intrinsic linearize-insn - [ conditional ] [ >intrinsic< ] bi* - _if-intrinsic emit-branch ; +M: ##binary-imm-branch linearize-insn + binary-conditional _binary-imm-branch emit-branch ; : linearize-basic-block ( bb -- ) [ number>> _label ] [ linearize-insns ] bi ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 64712297e2..f9fd4521f7 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,91 +1,37 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces math kernel alien classes ; +USING: accessors namespaces kernel arrays +parser prettyprint.backend prettyprint.sections ; IN: compiler.cfg.registers -! Virtual CPU registers, used by CFG and machine IRs - -MIXIN: value - -GENERIC: >vreg ( obj -- vreg ) -GENERIC: set-value-class ( class obj -- ) -GENERIC: value-class* ( operand -- class ) - -: value-class ( operand -- class ) value-class* object or ; - -M: value set-value-class 2drop ; -M: value value-class* drop f ; - -! Virtual registers +! Virtual registers, used by CFG and machine IRs TUPLE: vreg reg-class n ; SYMBOL: vreg-counter : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; -M: vreg >vreg ; - -INSTANCE: vreg value - ! Stack locations -TUPLE: loc n class ; +TUPLE: loc n ; -M: loc >vreg drop f ; - -! A data stack location. TUPLE: ds-loc < loc ; -: ( n -- loc ) f ds-loc boa ; +C: ds-loc TUPLE: rs-loc < loc ; -: ( n -- loc ) f rs-loc boa ; +C: ds-loc -INSTANCE: loc value +! Prettyprinting +: V scan-word scan-word vreg boa parsed ; parsing -! A tagged pointer -TUPLE: tagged vreg class ; -: ( vreg -- tagged ) f tagged boa ; +M: vreg pprint* + > pprint* ] [ n>> pprint* ] bi + block> ; -M: tagged set-value-class (>>class) ; -M: tagged value-class* class>> ; -M: tagged >vreg vreg>> ; +: pprint-loc ( loc word -- ) > pprint* block> ; -INSTANCE: tagged value +: D scan-word parsed ; parsing -! Unboxed value -TUPLE: unboxed vreg ; -C: unboxed +M: ds-loc pprint* \ D pprint-loc ; -M: unboxed >vreg vreg>> ; +: R scan-word parsed ; parsing -INSTANCE: unboxed value - -! Unboxed alien pointer -TUPLE: unboxed-alien < unboxed ; -C: unboxed-alien - -M: unboxed-alien value-class* drop simple-alien ; - -! Untagged byte array pointer -TUPLE: unboxed-byte-array < unboxed ; -C: unboxed-byte-array - -M: unboxed-byte-array value-class* drop c-ptr ; - -! A register set to f -TUPLE: unboxed-f < unboxed ; -C: unboxed-f - -M: unboxed-f value-class* drop \ f ; - -! An alien, byte array or f -TUPLE: unboxed-c-ptr < unboxed ; -C: unboxed-c-ptr - -M: unboxed-c-ptr value-class* drop c-ptr ; - -! A constant value -TUPLE: constant value ; -C: constant - -M: constant value-class* value>> class ; -M: constant >vreg ; - -INSTANCE: constant value +M: rs-loc pprint* \ R pprint-loc ; diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor deleted file mode 100644 index 289c420f8f..0000000000 --- a/basis/compiler/cfg/templates/templates.factor +++ /dev/null @@ -1,86 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs accessors sequences kernel fry namespaces -quotations combinators classes.algebra compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.stacks ; -IN: compiler.cfg.templates - -TUPLE: template input output scratch clobber gc ; - -: live-vregs ( -- seq ) - [ stack>> [ >vreg ] map sift ] each-phantom append ; - -: clobbered ( template -- seq ) - [ output>> ] [ clobber>> ] bi append ; - -: clobbered? ( value name -- ? ) - \ clobbered get member? [ - >vreg \ live-vregs get member? - ] [ drop f ] if ; - -: lazy-load ( specs -- seq ) - [ length phantom-datastack get phantom-input ] keep - [ - 2dup second clobbered? - [ first (eager-load) ] [ first (lazy-load) ] if - ] 2map ; - -: load-inputs ( template -- assoc ) - [ - live-vregs \ live-vregs set - dup clobbered \ clobbered set - input>> [ values ] [ lazy-load ] bi zip - ] with-scope ; - -: alloc-scratch ( template -- assoc ) - scratch>> [ swap alloc-vreg ] assoc-map ; - -: do-template-inputs ( template -- defs uses ) - #! Load input values into registers and allocates scratch - #! registers. - [ alloc-scratch ] [ load-inputs ] bi ; - -: do-template-outputs ( template defs uses -- ) - [ output>> ] 2dip assoc-union '[ _ at ] map - phantom-datastack get phantom-append ; - -: apply-template ( pair quot -- ) - [ - first2 - dup gc>> [ t fresh-object ] when - dup do-template-inputs - [ do-template-outputs ] - [ [ [ >vreg ] assoc-map ] dip ] 2bi - ] dip call ; inline - -: phantom&spec ( phantom specs -- phantom' specs' ) - >r stack>> r> - [ length f pad-left ] keep - [ ] bi@ ; inline - -: value-matches? ( value spec -- ? ) - #! If the spec is a quotation and the value is a literal - #! fixnum, see if the quotation yields true when applied - #! to the fixnum. Otherwise, the values don't match. If the - #! spec is not a quotation, its a reg-class, in which case - #! the value is always good. - { - { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] } - { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] } - [ 2drop t ] - } cond ; - -: class-matches? ( actual expected -- ? ) - dup [ class<= ] [ 2drop t ] if ; - -: spec-matches? ( value spec -- ? ) - 2dup first value-matches? - >r >r value-class 2 r> ?nth class-matches? r> and ; - -: template-matches? ( template -- ? ) - input>> phantom-datastack get swap phantom&spec - [ spec-matches? ] 2all? ; - -: find-template ( templates -- pair/f ) - #! Pair has shape { quot assoc } - [ second template-matches? ] find nip ; diff --git a/basis/compiler/cfg/value-numbering/liveness/liveness.factor b/basis/compiler/cfg/value-numbering/liveness/liveness.factor index c445c0835d..127a584091 100644 --- a/basis/compiler/cfg/value-numbering/liveness/liveness.factor +++ b/basis/compiler/cfg/value-numbering/liveness/liveness.factor @@ -30,7 +30,7 @@ M: load-literal-expr live-expr in>> live-vn ; GENERIC: eliminate ( insn -- insn/f ) : (eliminate) ( insn -- insn/f ) - dup dst>> >vreg live? [ drop f ] unless ; + dup dst>> live? [ drop f ] unless ; M: ##peek eliminate (eliminate) ; M: ##unary eliminate (eliminate) ; diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor index 758d3f95e6..4bca1714ca 100644 --- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor +++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor @@ -9,11 +9,11 @@ IN: compiler.cfg.value-numbering.propagate GENERIC: propogate ( insn -- insn ) -M: ##cond-branch propagate [ resolve ] change-src ; +M: ##unary-branch propagate [ resolve ] change-src ; M: ##unary propogate [ resolve ] change-src ; -M: ##nullary propagate ; +M: ##flushable propagate ; M: ##replace propagate [ resolve ] change-src ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 81e8c40afd..a2957e59f8 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -6,9 +6,9 @@ IN: compiler.cfg.value-numbering GENERIC: make-value-node ( insn -- ) -M: ##cond-branch make-value-node src>> live-vreg ; +M: ##unary-branch make-value-node src>> live-vreg ; M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ; -M: ##nullary make-value-node drop ; +M: ##flushable make-value-node drop ; M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ; M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ; M: ##replace make-value-node reset-value-graph ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 6c83c38355..3f88873e6e 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,26 +4,21 @@ USING: namespaces make math math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays sets threads libc continuations.private -cpu.architecture +fry cpu.architecture compiler.errors compiler.alien -compiler.codegen.fixup compiler.cfg compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.builder ; +compiler.cfg.builder +compiler.codegen.fixup ; IN: compiler.codegen GENERIC: generate-insn ( insn -- ) -GENERIC: v>operand ( obj -- operand ) - SYMBOL: registers -M: constant v>operand - value>> [ tag-fixnum ] [ \ f tag-number ] if* ; - -M: value v>operand +: register ( vreg -- operand ) registers get at [ "Bad value" throw ] unless* ; : generate-insns ( insns -- code ) @@ -68,124 +63,142 @@ SYMBOL: labels : lookup-label ( id -- label ) labels get [ drop