From 239578353f0adf584d813ecffb366f2eae4e7e31 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 17 Oct 2008 15:35:04 -0500
Subject: [PATCH] Simplifying vregs work in progress
---
basis/compiler/cfg/builder/builder.factor | 2 +-
.../cfg/instructions/instructions.factor | 60 ++++++-------
basis/compiler/cfg/stacks/stacks.factor | 85 +++++++++----------
basis/compiler/cfg/templates/templates.factor | 19 ++---
basis/compiler/codegen/codegen.factor | 2 +-
5 files changed, 80 insertions(+), 88 deletions(-)
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 3bc4a738c1..8b5202dd63 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -253,7 +253,7 @@ M: #dispatch emit-node
type tagged boa phantom-push ;
: emit-write-barrier ( -- )
- phantom-pop dup >vreg fresh-object? [ drop ] [
+ phantom-pop dup fresh-object? [ drop ] [
int-regs next-vreg
int-regs next-vreg
##write-barrier
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d92520c77d..fd7d071518 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -1,21 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences namespaces
+USING: assocs accessors arrays kernel sequences namespaces words
math 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 ;
-TUPLE: ##unary < insn dst src ;
-TUPLE: ##nullary < insn dst ;
+TUPLE: ##cond-branch < insn { src vreg } ;
+TUPLE: ##unary < insn { dst vreg } { src vreg } ;
+TUPLE: ##nullary < insn { dst vreg } ;
! Stack operations
INSN: ##load-literal < ##nullary obj ;
-INSN: ##peek < ##nullary loc ;
-INSN: ##replace src loc ;
-INSN: ##inc-d n ;
-INSN: ##inc-r n ;
+INSN: ##peek < ##nullary { loc loc } ;
+INSN: ##replace { src vreg } { loc loc } ;
+INSN: ##inc-d { n integer } ;
+INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
@@ -33,8 +33,8 @@ INSN: ##return ;
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
-INSN: ##dispatch-label label ;
INSN: ##dispatch src temp ;
+INSN: ##dispatch-label label ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
@@ -44,12 +44,12 @@ INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ;
-INSN: ##box-float < ##unary temp ;
-INSN: ##box-alien < ##unary temp ;
+INSN: ##box-float < ##unary { temp vreg } ;
+INSN: ##box-alien < ##unary { temp vreg } ;
! Memory allocation
-INSN: ##allot < ##nullary size type tag temp ;
-INSN: ##write-barrier src card# table ;
+INSN: ##allot < ##nullary size type tag { temp vreg } ;
+INSN: ##write-barrier { src vreg } card# table ;
INSN: ##gc ;
! FFI
@@ -61,28 +61,28 @@ INSN: ##callback-return params ;
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: ##nullary defs-vregs dst>> >vreg 1array ;
-M: ##unary defs-vregs dst>> >vreg 1array ;
+M: ##nullary defs-vregs dst>> 1array ;
+M: ##unary defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs
- [ card#>> >vreg ] [ table>> >vreg ] bi 2array ;
+ [ card#>> ] [ table>> ] bi 2array ;
: allot-defs-vregs ( insn -- seq )
- [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
+ [ 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>> >vreg 1array ;
+M: ##dispatch defs-vregs temp>> 1array ;
M: insn defs-vregs drop f ;
-M: ##replace uses-vregs src>> >vreg 1array ;
-M: ##unary uses-vregs src>> >vreg 1array ;
-M: ##write-barrier uses-vregs src>> >vreg 1array ;
-M: ##dispatch uses-vregs src>> >vreg 1array ;
+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 >vreg ] { } assoc>map sift ;
+ values sift ;
: intrinsic-defs-vregs ( insn -- seq )
defs-vregs>> intrinsic-vregs ;
@@ -102,7 +102,7 @@ INSN: ##branch-f < ##cond-branch ;
INSN: ##branch-t < ##cond-branch ;
INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
-M: ##cond-branch uses-vregs src>> >vreg 1array ;
+M: ##cond-branch uses-vregs src>> 1array ;
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
@@ -113,20 +113,20 @@ INSN: _epilogue stack-frame ;
INSN: _label id ;
-TUPLE: _cond-branch < insn src label ;
+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>> >vreg 1array ;
+M: _cond-branch uses-vregs src>> 1array ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
-INSN: _spill-integer src n ;
-INSN: _reload-integer dst n ;
+INSN: _spill-integer { src vreg } n ;
+INSN: _reload-integer { dst vreg } n ;
-INSN: _spill-float src n ;
-INSN: _reload-float dst n ;
+INSN: _spill-float { src vreg } n ;
+INSN: _reload-float { dst vreg } n ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 39d8109b05..8d0537c64d 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -16,10 +16,7 @@ PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
! Value protocol
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-load) 1 ( value spec -- value )
-GENERIC# (eager-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- )
-GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: ##move
@@ -28,7 +25,6 @@ PRIVATE>
! Default implementation
M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
@@ -40,7 +36,6 @@ M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ;
M: float-regs value-class* drop float ;
-M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
@@ -67,14 +62,14 @@ M: unboxed-c-ptr move-spec class ;
M: constant move-spec class ;
! Moving values between locations and registers
-: ##move-bug ( -- * ) "Bug in generator.registers" throw ;
+: ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ;
: ##unbox-c-ptr ( dst src -- )
dup value-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 ]
+ { [ 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 -- )
@@ -97,28 +92,28 @@ SYMBOL: fresh-objects
: ##move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
- { { f f } [ ##copy ] }
- { { unboxed-alien unboxed-alien } [ ##copy ] }
- { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
- { { unboxed-f unboxed-f } [ ##copy ] }
- { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
- { { float float } [ ##copy-float ] }
+ { { 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 } [ value>> ##load-literal ] }
+ { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
- { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
- { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
- { { f loc } [ ##peek ] }
+ { { 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 } [ ##unbox-float ] }
- { { unboxed-alien f } [ ##unbox-alien ] }
- { { unboxed-byte-array f } [ ##unbox-byte-array ] }
- { { unboxed-f f } [ ##unbox-f ] }
+ { { 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 } [ swap ##replace ] }
+ { { loc f } [ >vreg swap ##replace ] }
[ drop ##move-via-temp ]
} case ;
@@ -168,7 +163,7 @@ M: phantom-retainstack finalize-height
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
- >r <reversed> r> '[ _ <loc> ] map ;
+ [ <reversed> ] dip '[ _ <loc> ] map ;
: phantom-locs* ( phantom -- locs )
[ stack>> length ] keep phantom-locs ;
@@ -209,15 +204,6 @@ M: phantom-retainstack finalize-height
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-: (live-locs) ( phantom -- seq )
- #! Discard locs which haven't moved
- [ phantom-locs* ] [ stack>> ] bi zip
- [ live-loc? ] assoc-filter
- values ;
-
-: live-locs ( -- seq )
- [ (live-locs) ] each-phantom append prune ;
-
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
@@ -231,6 +217,14 @@ M: phantom-retainstack finalize-height
[ 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 ] }
@@ -240,20 +234,21 @@ M: phantom-retainstack finalize-height
[ f ]
} cond 2nip ;
-: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap value-class
- over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
+: (lazy-load) ( value spec -- value )
{
- { [ dup { small-slot small-tagged } memq? ] [ drop ] }
- { [ 2dup compatible? ] [ drop ] }
+ { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
+ { [ 2dup compatible? ] [ drop >vreg ] }
[ (eager-load) ]
} cond ;
-M: value (eager-load) ( value spec -- vreg )
- [ alloc-vreg-for ] [ drop ] 2bi
- [ ##move ] [ drop ] 2bi ;
+: (live-locs) ( phantom -- seq )
+ #! Discard locs which haven't moved
+ [ phantom-locs* ] [ stack>> ] bi zip
+ [ live-loc? ] assoc-filter
+ values ;
+
+: live-locs ( -- seq )
+ [ (live-locs) ] each-phantom append prune ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
index 33c0efae55..9446d66683 100644
--- a/basis/compiler/cfg/templates/templates.factor
+++ b/basis/compiler/cfg/templates/templates.factor
@@ -7,14 +7,6 @@ IN: compiler.cfg.templates
TUPLE: template input output scratch clobber gc ;
-: phantom&spec ( phantom specs -- phantom' specs' )
- >r stack>> r>
- [ length f pad-left ] keep
- [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
- >r phantom&spec r> 2all? ; inline
-
: live-vregs ( -- seq )
[ stack>> [ >vreg ] map sift ] each-phantom append ;
@@ -41,7 +33,7 @@ TUPLE: template input output scratch clobber gc ;
] with-scope ;
: alloc-scratch ( template -- assoc )
- scratch>> [ swap alloc-vreg ] assoc-map ;
+ scratch>> [ swap alloc-vreg >vreg ] assoc-map ;
: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
@@ -60,6 +52,11 @@ TUPLE: template input output scratch clobber gc ;
[ do-template-outputs ] 2keep
] 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
@@ -80,8 +77,8 @@ TUPLE: template input output scratch clobber gc ;
>r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
- input>> phantom-datastack get swap
- [ spec-matches? ] phantom&spec-agree? ;
+ input>> phantom-datastack get swap phantom&spec
+ [ spec-matches? ] 2all? ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot assoc }
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 0a79d14778..44e2fd6bac 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -24,7 +24,7 @@ M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
M: value v>operand
- >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+ registers get at [ "Bad value" throw ] unless* ;
: generate-insns ( insns -- code )
[