vreg usage cleanups

library/compiler/intrinsics.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! 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
+        dup in-1 >r slot@ r> %fast-slot ,
-        0 swap slot@ %fast-slot ,
     ] [
-        drop
+        in-2 swap
-        in-2
         -1 %inc-d ,
-        0 %untag ,
+        dup %untag ,
-        1 0 %slot ,
+        %slot ,
-    ] if  out-1
+    ] 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 ,
+        over %untag ,
-        0 1 2 %set-slot ,
+        %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 ,
+    [ %char-slot , ] keep
-    T{ vreg f 1 } T{ ds-loc f 0 } %replace ,
+    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 [ %type , ] keep out-1
-    in-1
-    0 %type ,
-    out-1
 ] "intrinsic" set-word-prop
 
 \ tag [
-    drop
+    in-1 [ %tag , ] keep out-1
-    in-1
-    0 %tag ,
-    out-1
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    -1 %inc-d ,
+    T{ vreg f 0 } [
-    node-peek value-literal 0 <vreg> swap %getenv ,
+        -1 %inc-d ,
-    1 %inc-d ,
+        swap node-peek value-literal %getenv ,
-    out-1
+        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 ,
+    node-in-d { T{ vreg f 0 } f } intrinsic-inputs first2 swap
-    T{ vreg f 0 } T{ ds-loc f 1 } pick node-peek load-value
+    -2 %inc-d , ;
-    node-peek value-literal T{ vreg f 0 } ;
 
-: binary-op-imm ( node op -- )
+\ setenv [
-    >r binary-imm dup r> execute , out-1 ; inline
+    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 -- ? )
+: (binary-op) ( node -- in1 in2 )
-    fixnum-imm? >r node-peek literal-immediate? r> and ;
+    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.
+    >r (binary-op) dup r> execute ,
-    over binary-op-imm?
+    1 %inc-d ,
-    [ binary-op-imm ] [ binary-op-reg ] if ;
+    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?
+    >r >r (binary-op) r> r> execute , ; inline
-    [ binary-jump-imm ] [ binary-jump-reg ] if ;
 
 {
     { 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 swap
-    in-2
     -1 %inc-d ,
-    1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
+    [ dup %fixnum-mod , ] keep out-1
-    T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    drop
+    in-2 swap 2array
-    in-2
-    { T{ vreg f 1 } T{ vreg f 0 } }
     { 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{ vreg f 2 } } out-n
-    T{ vreg f 0 } T{ ds-loc f 1 } %replace ,
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    drop
+    in-1 [ dup %fixnum-bitnot , ] keep out-1
-    in-1
-    0 <vreg> 0 <vreg> %fixnum-bitnot ,
-    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 ,
+        drop T{ vreg f 0 } T{ vreg f 2 } %fixnum-sgn ,
-        T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
+        T{ vreg f 2 } out-1
     ] [
-        neg 0 <vreg> 0 <vreg> %fixnum>> ,
+        neg T{ vreg f 0 } T{ vreg f 0 } %fixnum>> ,
-        out-1
+        T{ vreg f 0 } out-1
     ] if ;
 
 : fast-shift ( n -- )

library/compiler/linearizer.factor

@@ -81,20 +81,45 @@ M: #label linearize* ( node -- next )
     renamed-label swap node-child linearize-1
     r> ;
 
-: in-1
+: immediate? ( obj -- ? )
-    T{ vreg f 0 } T{ ds-loc f 0 } %peek , ;
+    #! 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
+: load-literal ( obj vreg -- )
-    T{ vreg f 0 } T{ ds-loc f 1 } %peek ,
+    over immediate? [ %immediate ] [ %indirect ] if , ;
-    T{ vreg f 1 } T{ ds-loc f 0 } %peek , ;
 
-: in-3
+GENERIC: load-value ( vreg loc value -- operand )
-    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 , ;
 
-: out-1
+M: object load-value ( vreg loc value -- operand )
-    T{ vreg f 0 } T{ ds-loc f 0 } %replace , ;
+    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 ,
+    dup in-1
-    [ <label> dup %target-label ,  2array ] map ;
+    -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 ;

library/compiler/stack.factor

@@ -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.

library/compiler/vops.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! 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 )
+: %fast-slot ( n vreg )
-    swap <vreg> 2-vop <%fast-slot> ;
+    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
+    over >r 3array r> 1array f <%fast-set-slot> ;
-    <%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 ;

library/freetype/freetype-gl.factor

@@ -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 [
             [