vreg usage cleanups
slava
parent
0ff2dbc4e0
commit
cfdefab518
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler-frontend
|
||||
USING: arrays assembler compiler-backend generic hashtables
|
||||
inference kernel kernel-internals lists math math-internals
|
||||
|
|
@ -32,111 +32,92 @@ namespaces sequences words ;
|
|||
\ slot [
|
||||
dup slot@ [
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
0 swap slot@ %fast-slot ,
|
||||
dup in-1 >r slot@ r> %fast-slot ,
|
||||
] [
|
||||
drop
|
||||
in-2
|
||||
in-2 swap
|
||||
-1 %inc-d ,
|
||||
0 %untag ,
|
||||
1 0 %slot ,
|
||||
] if out-1
|
||||
dup %untag ,
|
||||
%slot ,
|
||||
] if T{ vreg f 0 } out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
-1 %inc-d ,
|
||||
in-2
|
||||
dup in-2
|
||||
-2 %inc-d ,
|
||||
slot@ >r 0 1 r> %fast-set-slot ,
|
||||
rot slot@ %fast-set-slot ,
|
||||
] [
|
||||
drop
|
||||
in-3
|
||||
-3 %inc-d ,
|
||||
1 %untag ,
|
||||
0 1 2 %set-slot ,
|
||||
over %untag ,
|
||||
%set-slot ,
|
||||
] if
|
||||
1 %write-barrier ,
|
||||
T{ vreg f 1 } %write-barrier ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ char-slot [
|
||||
drop
|
||||
in-2
|
||||
-1 %inc-d ,
|
||||
0 1 %char-slot ,
|
||||
T{ vreg f 1 } T{ ds-loc f 0 } %replace ,
|
||||
[ %char-slot , ] keep
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ set-char-slot [
|
||||
drop
|
||||
in-3
|
||||
-3 %inc-d ,
|
||||
0 2 1 %set-char-slot ,
|
||||
swap %set-char-slot ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ type [
|
||||
drop
|
||||
in-1
|
||||
0 %type ,
|
||||
out-1
|
||||
in-1 [ %type , ] keep out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ tag [
|
||||
drop
|
||||
in-1
|
||||
0 %tag ,
|
||||
out-1
|
||||
in-1 [ %tag , ] keep out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
-1 %inc-d ,
|
||||
node-peek value-literal 0 <vreg> swap %getenv ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
T{ vreg f 0 } [
|
||||
-1 %inc-d ,
|
||||
swap node-peek value-literal %getenv ,
|
||||
1 %inc-d ,
|
||||
] keep out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
node-peek value-literal 0 <vreg> swap %setenv ,
|
||||
-1 %inc-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
GENERIC: load-value ( vreg loc value -- )
|
||||
|
||||
M: object load-value ( vreg loc value -- )
|
||||
drop %peek , ;
|
||||
|
||||
M: value load-value ( vreg loc value -- )
|
||||
nip value-literal swap load-literal ;
|
||||
|
||||
: binary-inputs ( node -- in1 in2 )
|
||||
node-in-d
|
||||
T{ vreg f 0 } T{ ds-loc f 1 } pick first load-value
|
||||
T{ vreg f 1 } T{ ds-loc f 0 } rot second load-value
|
||||
T{ vreg f 1 } T{ vreg f 0 } ;
|
||||
|
||||
: binary-op-reg ( node op -- )
|
||||
>r binary-inputs dup -1 %inc-d , r> execute , out-1 ; inline
|
||||
|
||||
: binary-imm ( node -- in1 in2 )
|
||||
-1 %inc-d ,
|
||||
T{ vreg f 0 } T{ ds-loc f 1 } pick node-peek load-value
|
||||
node-peek value-literal T{ vreg f 0 } ;
|
||||
node-in-d { T{ vreg f 0 } f } intrinsic-inputs first2 swap
|
||||
-2 %inc-d , ;
|
||||
|
||||
: binary-op-imm ( node op -- )
|
||||
>r binary-imm dup r> execute , out-1 ; inline
|
||||
\ setenv [
|
||||
binary-imm
|
||||
%setenv ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: binary-reg ( node -- in1 in2 )
|
||||
node-in-d { T{ vreg f 0 } T{ vreg f 1 } } intrinsic-inputs
|
||||
first2 swap -2 %inc-d , ;
|
||||
|
||||
: literal-immediate? ( value -- ? )
|
||||
dup value? [ value-literal immediate? ] [ drop f ] if ;
|
||||
|
||||
: binary-op-imm? ( node -- ? )
|
||||
fixnum-imm? >r node-peek literal-immediate? r> and ;
|
||||
: (binary-op) ( node -- in1 in2 )
|
||||
fixnum-imm? [
|
||||
dup node-peek literal-immediate?
|
||||
[ binary-imm ] [ binary-reg ] if
|
||||
] [
|
||||
binary-reg
|
||||
] if ;
|
||||
|
||||
: binary-op ( node op -- )
|
||||
#! out is a vreg where the vop stores the result.
|
||||
over binary-op-imm?
|
||||
[ binary-op-imm ] [ binary-op-reg ] if ;
|
||||
>r (binary-op) dup r> execute ,
|
||||
1 %inc-d ,
|
||||
T{ vreg f 0 } out-1 ; inline
|
||||
|
||||
: binary-op-reg ( node op -- )
|
||||
>r binary-reg dup r> execute ,
|
||||
1 %inc-d ,
|
||||
T{ vreg f 0 } out-1 ; inline
|
||||
|
||||
{
|
||||
{ fixnum+ %fixnum+ }
|
||||
|
|
@ -148,15 +129,8 @@ M: value load-value ( vreg loc value -- )
|
|||
first2 [ binary-op ] curry "intrinsic" set-word-prop
|
||||
] each
|
||||
|
||||
: binary-jump-reg ( node label op -- )
|
||||
>r >r binary-inputs -2 %inc-d , r> r> execute , ; inline
|
||||
|
||||
: binary-jump-imm ( node label op -- )
|
||||
>r >r binary-imm -1 %inc-d , r> r> execute , ; inline
|
||||
|
||||
: binary-jump ( node label op -- )
|
||||
pick binary-op-imm?
|
||||
[ binary-jump-imm ] [ binary-jump-reg ] if ;
|
||||
>r >r (binary-op) r> r> execute , ; inline
|
||||
|
||||
{
|
||||
{ fixnum<= %jump-fixnum<= }
|
||||
|
|
@ -176,29 +150,21 @@ M: value load-value ( vreg loc value -- )
|
|||
! This is not clever. Because of x86, %fixnum-mod is
|
||||
! hard-coded to put its output in vreg 2, which happends to
|
||||
! be EDX there.
|
||||
drop
|
||||
in-2
|
||||
in-2 swap
|
||||
-1 %inc-d ,
|
||||
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
|
||||
T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
|
||||
[ dup %fixnum-mod , ] keep out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum/mod [
|
||||
! See the remark on fixnum-mod for vreg usage
|
||||
drop
|
||||
in-2
|
||||
{ T{ vreg f 1 } T{ vreg f 0 } }
|
||||
in-2 swap 2array
|
||||
{ T{ vreg f 2 } T{ vreg f 0 } }
|
||||
%fixnum/mod ,
|
||||
T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
|
||||
T{ vreg f 0 } T{ ds-loc f 1 } %replace ,
|
||||
{ T{ vreg f 0 } T{ vreg f 2 } } out-n
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum-bitnot [
|
||||
drop
|
||||
in-1
|
||||
0 <vreg> 0 <vreg> %fixnum-bitnot ,
|
||||
out-1
|
||||
in-1 [ dup %fixnum-bitnot , ] keep out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ fixnum* [
|
||||
|
|
@ -209,13 +175,13 @@ M: value load-value ( vreg loc value -- )
|
|||
|
||||
: negative-shift ( n -- )
|
||||
-1 %inc-d ,
|
||||
in-1
|
||||
{ f } { T{ vreg f 0 } } intrinsic-inputs drop
|
||||
dup cell-bits neg <= [
|
||||
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
|
||||
T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
|
||||
drop T{ vreg f 0 } T{ vreg f 2 } %fixnum-sgn ,
|
||||
T{ vreg f 2 } out-1
|
||||
] [
|
||||
neg 0 <vreg> 0 <vreg> %fixnum>> ,
|
||||
out-1
|
||||
neg T{ vreg f 0 } T{ vreg f 0 } %fixnum>> ,
|
||||
T{ vreg f 0 } out-1
|
||||
] if ;
|
||||
|
||||
: fast-shift ( n -- )
|
||||
|
|
|
|||
|
|
@ -81,20 +81,45 @@ M: #label linearize* ( node -- next )
|
|||
renamed-label swap node-child linearize-1
|
||||
r> ;
|
||||
|
||||
: in-1
|
||||
T{ vreg f 0 } T{ ds-loc f 0 } %peek , ;
|
||||
: immediate? ( obj -- ? )
|
||||
#! fixnums and f have a pointerless representation, and
|
||||
#! are compiled immediately. Everything else can be moved
|
||||
#! by GC, and is indexed through a table.
|
||||
dup fixnum? swap f eq? or ;
|
||||
|
||||
: in-2
|
||||
T{ vreg f 0 } T{ ds-loc f 1 } %peek ,
|
||||
T{ vreg f 1 } T{ ds-loc f 0 } %peek , ;
|
||||
: load-literal ( obj vreg -- )
|
||||
over immediate? [ %immediate ] [ %indirect ] if , ;
|
||||
|
||||
: in-3
|
||||
T{ vreg f 0 } T{ ds-loc f 2 } %peek ,
|
||||
T{ vreg f 1 } T{ ds-loc f 1 } %peek ,
|
||||
T{ vreg f 2 } T{ ds-loc f 0 } %peek , ;
|
||||
GENERIC: load-value ( vreg loc value -- operand )
|
||||
|
||||
: out-1
|
||||
T{ vreg f 0 } T{ ds-loc f 0 } %replace , ;
|
||||
M: object load-value ( vreg loc value -- operand )
|
||||
drop dupd %peek , ;
|
||||
|
||||
M: value load-value ( vreg loc value -- operand )
|
||||
nip value-literal swap [ [ load-literal ] keep ] when* ;
|
||||
|
||||
: intrinsic-inputs ( seq template -- inputs )
|
||||
dup length reverse-slice [ <ds-loc> ] map rot 3array flip
|
||||
[ first3 load-value ] map ;
|
||||
|
||||
: in-1 ( node -- operand )
|
||||
node-in-d { T{ vreg f 0 } } intrinsic-inputs first ;
|
||||
|
||||
: in-2 ( node -- operand operand )
|
||||
node-in-d { T{ vreg f 0 } T{ vreg f 1 } }
|
||||
intrinsic-inputs first2 ;
|
||||
|
||||
: in-3 ( node -- operand operand operand )
|
||||
node-in-d { T{ vreg f 0 } T{ vreg f 1 } T{ vreg f 2 } }
|
||||
intrinsic-inputs first3 ;
|
||||
|
||||
: stacks<>vregs ( values quot quot -- )
|
||||
>r >r dup reverse-slice swap length r> map r> 2each ; inline
|
||||
|
||||
: out-n ( vregs -- )
|
||||
[ <ds-loc> ] [ %replace , ] stacks<>vregs ;
|
||||
|
||||
: out-1 ( vreg -- ) 1array out-n ;
|
||||
|
||||
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
|
||||
|
||||
|
|
@ -128,14 +153,17 @@ M: #if linearize* ( node -- next )
|
|||
-1 %inc-d ,
|
||||
swap node-children nth linearize-child iterate-next
|
||||
] [
|
||||
in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if
|
||||
dup in-1 -1 %inc-d , >r <label> dup r> %jump-t ,
|
||||
linearize-if
|
||||
] if* ;
|
||||
|
||||
: dispatch-head ( vtable -- label/node )
|
||||
: dispatch-head ( node -- label/node )
|
||||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
in-1 -1 %inc-d , 0 %dispatch ,
|
||||
[ <label> dup %target-label , 2array ] map ;
|
||||
dup in-1
|
||||
-1 %inc-d ,
|
||||
%dispatch ,
|
||||
node-children [ <label> dup %target-label , 2array ] map ;
|
||||
|
||||
: dispatch-body ( label/node -- )
|
||||
<label> swap [
|
||||
|
|
@ -145,6 +173,6 @@ M: #if linearize* ( node -- next )
|
|||
M: #dispatch linearize* ( node -- next )
|
||||
#! The parameter is a list of nodes, each one is a branch to
|
||||
#! take in case the top of stack has that type.
|
||||
node-children dispatch-head dispatch-body iterate-next ;
|
||||
dispatch-head dispatch-body iterate-next ;
|
||||
|
||||
M: #return linearize* drop %return , f ;
|
||||
|
|
|
|||
|
|
@ -4,15 +4,6 @@ IN: compiler-frontend
|
|||
USING: compiler-backend generic inference kernel math namespaces
|
||||
sequences vectors words ;
|
||||
|
||||
: immediate? ( obj -- ? )
|
||||
#! fixnums and f have a pointerless representation, and
|
||||
#! are compiled immediately. Everything else can be moved
|
||||
#! by GC, and is indexed through a table.
|
||||
dup fixnum? swap f eq? or ;
|
||||
|
||||
: load-literal ( obj vreg -- )
|
||||
over immediate? [ %immediate ] [ %indirect ] if , ;
|
||||
|
||||
SYMBOL: vreg-allocator
|
||||
SYMBOL: live-d
|
||||
SYMBOL: live-r
|
||||
|
|
@ -28,9 +19,6 @@ SYMBOL: live-r
|
|||
over value-dropped? [ 2drop ] [ >r get r> %peek , ] if
|
||||
vreg-allocator inc ;
|
||||
|
||||
: stacks<>vregs ( values quot quot -- )
|
||||
>r >r dup reverse-slice swap length r> map r> 2each ; inline
|
||||
|
||||
: stacks>vregs ( #shuffle -- )
|
||||
dup
|
||||
node-in-d [ <ds-loc> ] [ stack>vreg ] stacks<>vregs
|
||||
|
|
@ -65,7 +53,7 @@ SYMBOL: live-r
|
|||
#! stack slot actually clobbers a vreg.
|
||||
live-d get literals/computed
|
||||
live-r get literals/computed
|
||||
swapd vregs>stacks vregs>stacks ;
|
||||
swapd (vregs>stacks) (vregs>stacks) ;
|
||||
|
||||
: live-stores ( instack outstack -- stack )
|
||||
#! Avoid storing a value into its former position.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler-backend
|
||||
USING: arrays errors generic hashtables kernel kernel-internals
|
||||
lists math memory namespaces parser sequences words ;
|
||||
|
|
@ -139,12 +139,12 @@ C: %call make-vop ;
|
|||
|
||||
TUPLE: %jump-t ;
|
||||
C: %jump-t make-vop ;
|
||||
: %jump-t <vreg> label/src-vop <%jump-t> ;
|
||||
: %jump-t label/src-vop <%jump-t> ;
|
||||
|
||||
! dispatch tables
|
||||
TUPLE: %dispatch ;
|
||||
C: %dispatch make-vop ;
|
||||
: %dispatch <vreg> src-vop <%dispatch> ;
|
||||
: %dispatch src-vop <%dispatch> ;
|
||||
|
||||
TUPLE: %target-label ;
|
||||
C: %target-label make-vop ;
|
||||
|
|
@ -189,18 +189,16 @@ M: %indirect basic-block? drop t ;
|
|||
! object slot accessors
|
||||
TUPLE: %untag ;
|
||||
C: %untag make-vop ;
|
||||
: %untag <vreg> dest-vop <%untag> ;
|
||||
: %untag dest-vop <%untag> ;
|
||||
M: %untag basic-block? drop t ;
|
||||
|
||||
: slot-vop [ <vreg> ] 2apply 2-vop ;
|
||||
|
||||
TUPLE: %slot ;
|
||||
C: %slot make-vop ;
|
||||
: %slot ( n vreg ) slot-vop <%slot> ;
|
||||
: %slot ( n vreg ) 2-vop <%slot> ;
|
||||
M: %slot basic-block? drop t ;
|
||||
|
||||
: set-slot-vop
|
||||
rot <vreg> rot <vreg> rot <vreg> dup >r 3array r> 1array f ;
|
||||
[ 3array ] keep 1array f ;
|
||||
|
||||
TUPLE: %set-slot ;
|
||||
C: %set-slot make-vop ;
|
||||
|
|
@ -215,22 +213,21 @@ M: %set-slot basic-block? drop t ;
|
|||
! known at compile time, so these become a single instruction
|
||||
TUPLE: %fast-slot ;
|
||||
C: %fast-slot make-vop ;
|
||||
: %fast-slot ( vreg n )
|
||||
swap <vreg> 2-vop <%fast-slot> ;
|
||||
: %fast-slot ( n vreg )
|
||||
2-vop <%fast-slot> ;
|
||||
M: %fast-slot basic-block? drop t ;
|
||||
|
||||
TUPLE: %fast-set-slot ;
|
||||
C: %fast-set-slot make-vop ;
|
||||
: %fast-set-slot ( value obj n )
|
||||
#! %fast-set-slot writes to vreg obj.
|
||||
>r >r <vreg> r> <vreg> r> over >r 3array r> 1array f
|
||||
<%fast-set-slot> ;
|
||||
over >r 3array r> 1array f <%fast-set-slot> ;
|
||||
M: %fast-set-slot basic-block? drop t ;
|
||||
|
||||
! Char readers and writers
|
||||
TUPLE: %char-slot ;
|
||||
C: %char-slot make-vop ;
|
||||
: %char-slot ( n vreg ) slot-vop <%char-slot> ;
|
||||
: %char-slot ( n vreg ) 2-vop <%char-slot> ;
|
||||
M: %char-slot basic-block? drop t ;
|
||||
|
||||
TUPLE: %set-char-slot ;
|
||||
|
|
@ -244,7 +241,7 @@ M: %set-char-slot basic-block? drop t ;
|
|||
|
||||
TUPLE: %write-barrier ;
|
||||
C: %write-barrier make-vop ;
|
||||
: %write-barrier ( ptr ) <vreg> dest-vop <%write-barrier> ;
|
||||
: %write-barrier ( ptr ) dest-vop <%write-barrier> ;
|
||||
|
||||
! fixnum intrinsics
|
||||
TUPLE: %fixnum+ ;
|
||||
|
|
@ -318,11 +315,11 @@ C: %jump-eq? make-vop ;
|
|||
! some slightly optimized inline assembly
|
||||
TUPLE: %type ;
|
||||
C: %type make-vop ;
|
||||
: %type ( vreg ) <vreg> dest-vop <%type> ;
|
||||
: %type ( vreg ) dest-vop <%type> ;
|
||||
|
||||
TUPLE: %tag ;
|
||||
C: %tag make-vop ;
|
||||
: %tag ( vreg ) <vreg> dest-vop <%tag> ;
|
||||
: %tag ( vreg ) dest-vop <%tag> ;
|
||||
M: %tag basic-block? drop t ;
|
||||
|
||||
TUPLE: %getenv ;
|
||||
|
|
|
|||
|
|
@ -168,7 +168,7 @@ C: font ( handle -- font )
|
|||
#! glyph.
|
||||
[ dupd <char-sprite> ] cache-nth nip ;
|
||||
|
||||
: draw-string ( open-font sprites string -- )
|
||||
: (draw-string) ( open-font sprites string -- )
|
||||
GL_TEXTURE_2D [
|
||||
GL_MODELVIEW [
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue