From f092622facb1eb55cea39d3ec5c864b566577503 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 01:56:28 -0500
Subject: [PATCH] CFG IR is now pure SSA
---
.../compiler/cfg/builder/builder-tests.factor | 2 +
basis/compiler/cfg/builder/builder.factor | 125 +-----
basis/compiler/cfg/builder/calls/calls.factor | 360 ++++++++++++++++++
basis/compiler/cfg/builder/hats/hats.factor | 62 +++
.../cfg/{ => builder}/stacks/authors.txt | 0
.../cfg/{ => builder}/stacks/stacks.factor | 177 ++-------
basis/compiler/cfg/debugger/debugger.factor | 17 +-
basis/compiler/cfg/def-use/def-use.factor | 31 ++
.../cfg/instructions/instructions.factor | 192 +++++++---
.../linear-scan/assignment/assignment.factor | 1 +
.../live-intervals/live-intervals.factor | 3 +-
.../cfg/linearization/linearization.factor | 19 +-
basis/compiler/cfg/registers/registers.factor | 88 +----
basis/compiler/cfg/templates/templates.factor | 86 -----
.../value-numbering/liveness/liveness.factor | 2 +-
.../propagate/propagate.factor | 4 +-
.../value-numbering/value-numbering.factor | 4 +-
basis/compiler/codegen/codegen.factor | 219 ++++++-----
basis/compiler/codegen/fixup/fixup.factor | 5 +-
basis/compiler/tests/simple.factor | 8 +-
basis/compiler/tests/templates.factor | 5 +
basis/compiler/tree/builder/builder.factor | 2 +-
.../tree/combinators/combinators.factor | 2 +-
basis/compiler/tree/debugger/debugger.factor | 2 +-
.../known-words/known-words.factor | 2 +-
basis/cpu/architecture/architecture.factor | 180 +++++----
basis/cpu/ppc/allot/allot.factor | 2 +-
basis/cpu/x86/32/32.factor | 6 +-
basis/cpu/x86/64/64.factor | 11 +-
.../cpu/x86/architecture/architecture.factor | 16 +-
30 files changed, 923 insertions(+), 710 deletions(-)
create mode 100644 basis/compiler/cfg/builder/calls/calls.factor
create mode 100644 basis/compiler/cfg/builder/hats/hats.factor
rename basis/compiler/cfg/{ => builder}/stacks/authors.txt (100%)
rename basis/compiler/cfg/{ => builder}/stacks/stacks.factor (52%)
create mode 100644 basis/compiler/cfg/def-use/def-use.factor
delete mode 100644 basis/compiler/cfg/templates/templates.factor
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 } [
- <constant> 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>> <constant> 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 )
+ <reversed> [ 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 [ <tagged> ] }
- { unboxed-alien [ <unboxed-alien> ] }
- { unboxed-byte-array [ <unboxed-byte-array> ] }
- { unboxed-f [ <unboxed-f> ] }
- { unboxed-c-ptr [ <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 ;
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
+C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
+C: <rs-loc> ds-loc
-INSTANCE: loc value
+! Prettyprinting
+: V scan-word scan-word vreg boa parsed ; parsing
-! A tagged pointer
-TUPLE: tagged vreg class ;
-: <tagged> ( vreg -- tagged ) f tagged boa ;
+M: vreg pprint*
+ <block
+ \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+ block> ;
-M: tagged set-value-class (>>class) ;
-M: tagged value-class* class>> ;
-M: tagged >vreg vreg>> ;
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
-INSTANCE: tagged value
+: D scan-word <ds-loc> parsed ; parsing
-! Unboxed value
-TUPLE: unboxed vreg ;
-C: <unboxed> unboxed
+M: ds-loc pprint* \ D pprint-loc ;
-M: unboxed >vreg vreg>> ;
+: R scan-word <rs-loc> parsed ; parsing
-INSTANCE: unboxed value
-
-! Unboxed alien pointer
-TUPLE: unboxed-alien < unboxed ;
-C: <unboxed-alien> unboxed-alien
-
-M: unboxed-alien value-class* drop simple-alien ;
-
-! Untagged byte array pointer
-TUPLE: unboxed-byte-array < unboxed ;
-C: <unboxed-byte-array> unboxed-byte-array
-
-M: unboxed-byte-array value-class* drop c-ptr ;
-
-! A register set to f
-TUPLE: unboxed-f < unboxed ;
-C: <unboxed-f> unboxed-f
-
-M: unboxed-f value-class* drop \ f ;
-
-! An alien, byte array or f
-TUPLE: unboxed-c-ptr < unboxed ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-
-M: unboxed-c-ptr value-class* drop c-ptr ;
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> 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
- [ <reversed> ] 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 <label> ] cache ;
-M: _label generate-insn
- id>> lookup-label , ;
+M: ##load-immediate generate-insn
+ [ dst>> register ] [ obj>> ] bi %load-immediate ;
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: ##load-literal generate-insn
- [ obj>> ] [ dst>> v>operand ] bi load-literal ;
+M: ##load-indirect generate-insn
+ [ dst>> register ] [ obj>> ] bi %load-indirect ;
M: ##peek generate-insn
- [ dst>> v>operand ] [ loc>> ] bi %peek ;
+ [ dst>> register ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
- [ src>> v>operand ] [ loc>> ] bi %replace ;
+ [ src>> register ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
-M: ##return generate-insn drop %return ;
-
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
-SYMBOL: operands
-
-: init-intrinsic ( insn -- )
- [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
-
-M: ##intrinsic generate-insn
- [ init-intrinsic ] [ quot>> call ] bi ;
-
-: (operand) ( name -- operand )
- operands get at* [ "Bad operand name" throw ] unless ;
-
-: literal ( name -- value )
- (operand) value>> ;
-
-: operand ( name -- operand )
- (operand) v>operand ;
-
-: operand-class ( var -- class )
- (operand) value-class ;
-
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
-: unique-operands ( operands quot -- )
- >r [ operand ] map prune r> each ; inline
-
-M: _if-intrinsic generate-insn
- [ init-intrinsic ]
- [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-M: _branch-f generate-insn
- [ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
-
-M: _branch-t generate-insn
- [ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
+M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
- [ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
+ [ src>> register ] [ temp>> register ] bi %dispatch ;
+
+: >slot<
+ {
+ [ dst>> register ]
+ [ obj>> register ]
+ [ slot>> dup vreg? [ register ] when ]
+ [ tag>> ]
+ } cleave ; inline
+
+M: ##slot generate-insn >slot< %slot ;
+
+M: ##slot-imm generate-insn >slot< %slot-imm ;
+
+: >set-slot<
+ {
+ [ src>> register ]
+ [ obj>> register ]
+ [ slot>> dup vreg? [ register ] when ]
+ [ tag>> ]
+ } cleave ; inline
+
+M: ##set-slot generate-insn >set-slot< %set-slot ;
+
+M: ##set-slot-imm generate-insn >set-slot< %set-slot-imm ;
: dst/src ( insn -- dst src )
- [ dst>> v>operand ] [ src>> v>operand ] bi ;
+ [ dst>> register ] [ src>> register ] bi ; inline
-M: ##copy generate-insn dst/src %copy ;
+: dst/src1/src2 ( insn -- dst src1 src2 )
+ [ dst>> register ] [ src1>> register ] [ src2>> register ] tri ; inline
-M: ##copy-float generate-insn dst/src %copy-float ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-
-M: ##unbox-f generate-insn dst/src %unbox-f ;
-
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
-
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
-
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+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-imm generate-insn dst/src1/src2 %shl-imm ;
+M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
+M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
+M: ##not generate-insn dst/src %not ;
: dst/src/temp ( insn -- dst src temp )
- [ dst/src ] [ temp>> v>operand ] bi ;
+ [ dst/src ] [ temp>> register ] bi ; inline
-M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
+M: ##bignum>integer generate-insn dst/src %bignum>integer ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
+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: ##integer>float generate-insn dst/src/temp %integer>float ;
+M: ##float>integer generate-insn dst/src %float>integer ;
+
+M: ##copy generate-insn dst/src %copy ;
+M: ##copy-float generate-insn dst/src %copy-float ;
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+M: ##unbox-f generate-insn dst/src %unbox-f ;
+M: ##unbox-alien generate-insn dst/src %unbox-alien ;
+M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
+
+M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
+M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
+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-3 generate-insn dst/src %alien-signed-3 ;
+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< [ src>> register ] [ value>> register ] bi ;
+
+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>> v>operand ]
+ [ dst>> register ]
[ size>> ]
[ type>> ]
[ tag>> ]
- [ temp>> v>operand ]
+ [ temp>> register ]
} cleave
%allot ;
M: ##write-barrier generate-insn
- [ src>> v>operand ]
- [ card#>> v>operand ]
- [ table>> v>operand ]
+ [ src>> register ]
+ [ card#>> register ]
+ [ table>> register ]
tri %write-barrier ;
M: ##gc generate-insn drop %gc ;
-! #alien-invoke
+! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@@ -276,7 +289,7 @@ M: long-long-type flatten-value-type ( type -- types )
>r
alien-parameters
flatten-value-types
- r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ r> '[ alloc-parameter _ execute ] each-parameter ;
inline
: unbox-parameters ( offset node -- )
@@ -331,7 +344,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- )
dup dll-valid? [
- dupd [ dlsym ] curry contains?
+ dupd '[ _ dlsym ] contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
@@ -407,7 +420,7 @@ TUPLE: callback-context ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
@@ -436,6 +449,32 @@ M: ##alien-callback generate-insn
[ 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 , ;
+
+M: _branch generate-insn
+ label>> lookup-label %jump-label ;
+
+: >binary-branch< ( insn -- label src1 src2 cc )
+ {
+ [ label>> lookup-label ]
+ [ src1>> register ]
+ [ src2>> dup vreg? [ register ] when ]
+ [ cc>> ]
+ } cleave ;
+
+M: _binary-branch generate-insn
+ >binary-branch< %binary-branch ;
+
+M: _binary-imm-branch generate-insn
+ >binary-branch< %binary-imm-branch ;
+
M: _spill generate-insn
[ src>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %spill-integer ] }
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 6e45ab27e9..fe270f4410 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -43,9 +43,10 @@ M: rel-fixup fixup*
M: integer fixup* , ;
+: indq ( elt seq -- n ) [ eq? ] with find drop ;
+
: adjoin* ( obj table -- n )
- 2dup swap [ eq? ] curry find drop
- [ 2nip ] [ dup length >r push r> ] if* ;
+ 2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
index 671171a959..2f413b642a 100644
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@@ -1,8 +1,10 @@
-USING: compiler.units tools.test kernel kernel.private
-sequences.private math.private math combinators strings
-alien arrays memory vocabs parser eval ;
+USING: compiler compiler.units tools.test kernel kernel.private
+sequences.private math.private math combinators strings alien
+arrays memory vocabs parser eval ;
IN: compiler.tests
+\ (compile) must-infer
+
! Test empty word
[ ] [ [ ] compile-call ] unit-test
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index 6bcbb8baea..675e0cbc0f 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -375,3 +375,8 @@ TUPLE: my-tuple ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
+
+! Regression
+: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
+
+[ { f f f } ] [ t bad-value-bug ] unit-test
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 54bc445b25..19d80ec14f 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
- [ V{ } clone stack-visitor set ] prepose
+ '[ V{ } clone stack-visitor set @ ]
with-infer ; inline
: build-tree ( quot -- nodes )
diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor
index f284a06a88..40bbf81a03 100644
--- a/basis/compiler/tree/combinators/combinators.factor
+++ b/basis/compiler/tree/combinators/combinators.factor
@@ -48,7 +48,7 @@ IN: compiler.tree.combinators
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
-: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 4d2881af5a..59a028a4f4 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -24,7 +24,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
- [ [ ] curry ] assoc-map [ match-cond ] curry ;
+ [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
MATCH-VARS: ?a ?b ?c ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 9f208bdc12..9d26ab2f4a 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -277,7 +277,7 @@ generic-comparison-ops [
}
} cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
- [ 2nip ] curry "outputs" set-word-prop
+ '[ 2drop _ ] "outputs" set-word-prop
] each
{ <tuple> <tuple-boa> (tuple) } [
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 2d3f8a8b40..277d83412b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets ;
+classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
! Labels
@@ -35,60 +35,96 @@ GENERIC: param-reg ( n register-class -- reg )
M: object param-reg param-regs nth ;
-! Sequence mapping vreg-n to native assembler registers
-GENERIC: vregs ( register-class -- regs )
+HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-indirect cpu ( reg obj -- )
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj reg -- )
-
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( stack-frame -- n )
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-! Call another word
-HOOK: %call cpu ( word -- )
-
-! Local jump for branches
-HOOK: %jump-label cpu ( label -- )
-
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label vreg -- )
-
-! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label vreg -- )
-
-HOOK: %dispatch cpu ( src temp -- )
-
-HOOK: %dispatch-label cpu ( word -- )
-
-! Return to caller
-HOOK: %return cpu ( -- )
-
-! Change datastack height
+HOOK: %peek cpu ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
HOOK: %inc-d cpu ( n -- )
-
-! Change callstack height
HOOK: %inc-r cpu ( n -- )
-! Load stack into vreg
-HOOK: %peek cpu ( vreg loc -- )
+HOOK: stack-frame-size cpu ( stack-frame -- n )
+HOOK: %call cpu ( word -- )
+HOOK: %jump-label cpu ( label -- )
+HOOK: %return cpu ( -- )
-! Store vreg to stack
-HOOK: %replace cpu ( vreg loc -- )
+HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( word -- )
+
+HOOK: %slot cpu ( dst obj slot tag -- )
+HOOK: %slot-imm cpu ( dst obj slot tag -- )
+HOOK: %set-slot cpu ( src obj slot tag -- )
+HOOK: %set-slot-imm cpu ( src obj slot tag -- )
+
+HOOK: %add cpu ( dst src1 src2 -- )
+HOOK: %add-imm cpu ( dst src1 src2 -- )
+HOOK: %sub cpu ( dst src1 src2 -- )
+HOOK: %sub-imm cpu ( dst src1 src2 -- )
+HOOK: %mul cpu ( dst src1 src2 -- )
+HOOK: %mul-imm cpu ( dst src1 src2 -- )
+HOOK: %and cpu ( dst src1 src2 -- )
+HOOK: %and-imm cpu ( dst src1 src2 -- )
+HOOK: %or cpu ( dst src1 src2 -- )
+HOOK: %or-imm cpu ( dst src1 src2 -- )
+HOOK: %xor cpu ( dst src1 src2 -- )
+HOOK: %xor-imm cpu ( dst src1 src2 -- )
+HOOK: %shl-imm cpu ( dst src1 src2 -- )
+HOOK: %shr-imm cpu ( dst src1 src2 -- )
+HOOK: %sar-imm cpu ( dst src1 src2 -- )
+HOOK: %not cpu ( dst src -- )
+
+HOOK: %integer>bignum cpu ( dst src -- )
+HOOK: %bignum>integer cpu ( dst src -- )
+
+HOOK: %add-float cpu ( dst src1 src2 -- )
+HOOK: %sub-float cpu ( dst src1 src2 -- )
+HOOK: %mul-float cpu ( dst src1 src2 -- )
+HOOK: %div-float cpu ( dst src1 src2 -- )
+
+HOOK: %integer>float cpu ( dst src -- )
+HOOK: %float>integer cpu ( dst src -- )
-! Copy values between vregs
HOOK: %copy cpu ( dst src -- )
HOOK: %copy-float cpu ( dst src -- )
-
-! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-float cpu ( dst src temp -- )
+HOOK: %box-alien cpu ( dst src temp -- )
+
+HOOK: %alien-unsigned-1 cpu ( dst src -- )
+HOOK: %alien-unsigned-2 cpu ( dst src -- )
+HOOK: %alien-unsigned-4 cpu ( dst src -- )
+HOOK: %alien-signed-1 cpu ( dst src -- )
+HOOK: %alien-signed-2 cpu ( dst src -- )
+HOOK: %alien-signed-3 cpu ( dst src -- )
+HOOK: %alien-cell cpu ( dst src -- )
+HOOK: %alien-float cpu ( dst src -- )
+HOOK: %alien-double cpu ( dst src -- )
+
+HOOK: %set-alien-integer-1 cpu ( src value -- )
+HOOK: %set-alien-integer-2 cpu ( src value -- )
+HOOK: %set-alien-integer-4 cpu ( src value -- )
+HOOK: %set-alien-cell cpu ( src value -- )
+HOOK: %set-alien-float cpu ( src value -- )
+HOOK: %set-alien-double cpu ( src value -- )
+
+HOOK: %allot cpu ( dst size type tag temp -- )
+HOOK: %write-barrier cpu ( src card# table -- )
+HOOK: %gc cpu ( -- )
+
+HOOK: %prologue cpu ( n -- )
+HOOK: %epilogue cpu ( n -- )
+
+HOOK: %binary-branch cpu ( label src1 src2 label cc -- )
+HOOK: %binary-imm-branch cpu ( label src1 src2 label cc -- )
+
+HOOK: %spill-integer cpu ( src n -- )
+HOOK: %spill-float cpu ( src n -- )
+HOOK: %reload-integer cpu ( dst n -- )
+HOOK: %reload-float cpu ( dst n -- )
! FFI stuff
@@ -141,6 +177,10 @@ HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
+
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
@@ -150,59 +190,17 @@ HOOK: %callback-return cpu ( params -- )
M: object %callback-return drop %return ;
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
-
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
-M: object load-literal load-indirect ;
-
: if-small-struct ( n size true false -- ? )
- [ over not over struct-small-enough? and ] 2dip
- [ [ nip ] prepose ] dip if ;
+ [ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
+ [ '[ nip @ ] ] dip if ;
inline
: %unbox-struct ( n c-type -- )
- [
- %unbox-small-struct
- ] [
- %unbox-large-struct
- ] if-small-struct ;
+ [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
: %box-struct ( n c-type -- )
- [
- %box-small-struct
- ] [
- %box-large-struct
- ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src temp -- )
-
-! Allocation
-HOOK: %allot cpu ( dst size type tag temp -- )
-
-HOOK: %write-barrier cpu ( src card# table -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
-
-! Spilling
-HOOK: %spill-integer cpu ( src n -- )
-
-HOOK: %spill-float cpu ( src n -- )
-
-HOOK: %reload-integer cpu ( dst n -- )
-
-HOOK: %reload-float cpu ( dst n -- )
+ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
index 5868316577..3190973f26 100644
--- a/basis/cpu/ppc/allot/allot.factor
+++ b/basis/cpu/ppc/allot/allot.factor
@@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
! is it zero?
0 over v>operand 0 CMPI
"non-zero" get BNE
- 0 >bignum over load-literal
+ dup 0 >bignum %load-literal
"end" get B
! it is non-zero
"non-zero" resolve-label
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index e7e654c8f7..cc25f06cc9 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -41,7 +41,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
-M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
M: int-regs load-return-reg
@@ -51,7 +50,6 @@ M: int-regs store-return-reg
[ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
-M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
@@ -81,8 +79,8 @@ M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
-M: x86.32 load-indirect
- 0 [] MOV rc-absolute-cell rel-literal ;
+M: x86.32 %load-indirect
+ swap 0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index a78b4d8d92..3db92d82a5 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -26,17 +26,10 @@ M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
-M: float-regs vregs
- drop {
- XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
- XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
- } ;
-
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
@@ -44,8 +37,8 @@ M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
-M: x86.64 load-indirect ( literal reg -- )
- 0 [] MOV rc-relative rel-literal ;
+M: x86.64 %load-indirect ( literal reg -- )
+ swap 0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
drop
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 3b48610fe7..6d0860deee 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -71,11 +71,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
-M: f load-literal
- \ f tag-number MOV drop ;
-
-M: fixnum load-literal
- swap tag-fixnum MOV ;
+M: x86 %load-immediate MOV ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
@@ -118,11 +114,11 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
-M: x86 %jump-f ( label reg -- )
- \ f tag-number CMP JE ;
-
-M: x86 %jump-t ( label reg -- )
- \ f tag-number CMP JNE ;
+! M: x86 %jump-f ( label reg -- )
+! \ f tag-number CMP JE ;
+!
+! M: x86 %jump-t ( label reg -- )
+! \ f tag-number CMP JNE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;