steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Further compiler refactoring, implemented "templates"

slava 2006-04-02 04:42:36 +00:00
parent ded9d3d11b
commit 839080c225
2 changed files with 95 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
library/compiler/intrinsics.factor
View File

@ -5,8 +5,6 @@ USING: arrays assembler compiler-backend generic hashtables
inference kernel kernel-internals lists math math-internals inference kernel kernel-internals lists math math-internals
namespaces sequences words ; namespaces sequences words ;
: node-peek ( node -- value ) node-in-d peek ;
: type-tag ( type -- tag ) : type-tag ( type -- tag )
#! Given a type number, return the tag number. #! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ; dup 6 > [ drop 3 ] when ;
@ -31,93 +29,82 @@ namespaces sequences words ;
\ slot [ \ slot [
dup slot@ [ dup slot@ [
-1 %inc-d , { { 0 "obj" } { f "slot" } } { "obj" } [
dup in-1 >r slot@ r> %fast-slot , node get slot@ "obj" get %fast-slot ,
] with-template
] [ ] [
in-2 swap { { 0 "obj" } { 1 "n" } } { "obj" } [
-1 %inc-d , "obj" get %untag ,
dup %untag , "n" get "obj" get %slot ,
%slot , ] with-template
] if T{ vreg f 0 } out-1 ] if
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ set-slot [ \ set-slot [
dup slot@ [ dup slot@ [
-1 %inc-d , { { 0 "val" } { 1 "obj" } { f "slot" } } { } [
dup in-2 "val" get "obj" get node get slot@ %fast-set-slot ,
-2 %inc-d , ] with-template
rot slot@ %fast-set-slot ,
] [ ] [
in-3 { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
-3 %inc-d , "obj" get %untag ,
over %untag , "val" get "obj" get "slot" get %set-slot ,
%set-slot , ] with-template
] if ] if
T{ vreg f 1 } %write-barrier , T{ vreg f 1 } %write-barrier ,
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ char-slot [ \ char-slot [
in-2 { { 0 "n" } { 1 "str" } } { "str" } [
-1 %inc-d , "n" get "str" get %char-slot ,
[ %char-slot , ] keep ] with-template
out-1
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ set-char-slot [ \ set-char-slot [
in-3 { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
-3 %inc-d , "ch" get "str" get "n" get %set-char-slot ,
swap %set-char-slot , ] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ type [ \ type [
in-1 [ %type , ] keep out-1 { { 0 "in" } } { "in" } [ "in" get %type , ] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ tag [ \ tag [
in-1 [ %tag , ] keep out-1 { { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ getenv [ \ getenv [
T{ vreg f 0 } [ { { f "env" } } { "out" } [
-1 %inc-d , T{ vreg f 0 } "out" set
swap node-peek value-literal %getenv , "out" get "env" get %getenv ,
1 %inc-d , ] with-template
] keep out-1
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
: binary-imm ( node -- in1 in2 )
node-in-d { T{ vreg f 0 } f } intrinsic-inputs first2 swap
-2 %inc-d , ;
\ setenv [ \ setenv [
binary-imm { { 0 "value" } { f "env" } } { } [
%setenv , "env" get "value" get %setenv ,
] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
: binary-reg ( node -- in1 in2 ) : literal-immediate? ( node -- ? )
node-in-d { T{ vreg f 0 } T{ vreg f 1 } } intrinsic-inputs node-in-d peek dup value?
first2 swap -2 %inc-d , ; [ value-literal immediate? ] [ drop f ] if ;
: literal-immediate? ( value -- ? ) : binary-in ( node -- in )
dup value? [ value-literal immediate? ] [ drop f ] if ; literal-immediate? fixnum-imm? and
{ { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
: (binary-op) ( node -- in1 in2 ) : (binary-op) ( node in -- )
fixnum-imm? [ { "x" } [
dup node-peek literal-immediate? >r "y" get "x" get dup r> execute ,
[ binary-imm ] [ binary-reg ] if ] with-template ; inline
] [
binary-reg
] if ;
: binary-op ( node op -- ) : binary-op ( node op -- )
>r (binary-op) dup r> execute , swap dup binary-in (binary-op) ; inline
1 %inc-d ,
T{ vreg f 0 } out-1 ; inline
: binary-op-reg ( node op -- ) : binary-op-reg ( node op -- )
>r binary-reg dup r> execute , swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
1 %inc-d ,
T{ vreg f 0 } out-1 ; inline
{ {
{ fixnum+ %fixnum+ } { fixnum+ %fixnum+ }
@ -130,7 +117,9 @@ namespaces sequences words ;
] each ] each
: binary-jump ( node label op -- ) : binary-jump ( node label op -- )
>r >r (binary-op) r> r> execute , ; inline rot dup binary-in { } [
>r >r "y" get "x" get r> r> execute ,
] with-template ; inline
{ {
{ fixnum<= %jump-fixnum<= } { fixnum<= %jump-fixnum<= }
@ -150,21 +139,26 @@ namespaces sequences words ;
! This is not clever. Because of x86, %fixnum-mod is ! This is not clever. Because of x86, %fixnum-mod is
! hard-coded to put its output in vreg 2, which happends to ! hard-coded to put its output in vreg 2, which happends to
! be EDX there. ! be EDX there.
in-2 swap { { 0 "x" } { 1 "y" } } { "out" } [
-1 %inc-d , T{ vreg f 2 } "out" set
[ dup %fixnum-mod , ] keep out-1 "y" get "x" get "out" get %fixnum-mod ,
] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ fixnum/mod [ \ fixnum/mod [
! See the remark on fixnum-mod for vreg usage ! See the remark on fixnum-mod for vreg usage
in-2 swap 2array { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
{ T{ vreg f 2 } T{ vreg f 0 } } T{ vreg f 0 } "quo" set
%fixnum/mod , T{ vreg f 2 } "rem" set
{ T{ vreg f 0 } T{ vreg f 2 } } out-n "y" get "x" get 2array
"rem" get "quo" get 2array %fixnum/mod ,
] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ fixnum-bitnot [ \ fixnum-bitnot [
in-1 [ dup %fixnum-bitnot , ] keep out-1 { { 0 "x" } } { "x" } [
"x" get dup %fixnum-bitnot ,
] with-template
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop
\ fixnum* [ \ fixnum* [
@ -173,32 +167,32 @@ namespaces sequences words ;
: slow-shift ( -- ) \ fixnum-shift %call , ; : slow-shift ( -- ) \ fixnum-shift %call , ;
: negative-shift ( n -- ) : negative-shift ( n node -- )
-1 %inc-d , { { 0 "x" } { f "n" } } { "out" } [
{ f } { T{ vreg f 0 } } intrinsic-inputs drop
dup cell-bits neg <= [ dup cell-bits neg <= [
drop T{ vreg f 0 } T{ vreg f 2 } %fixnum-sgn ,
T{ vreg f 2 } out-1
] [
neg T{ vreg f 0 } T{ vreg f 0 } %fixnum>> ,
T{ vreg f 0 } out-1
] if ;
: fast-shift ( n -- )
dup zero? [
-1 %inc-d ,
drop drop
T{ vreg f 2 } "out" set
"x" get "out" get %fixnum-sgn ,
] [ ] [
dup 0 < [ "x" get "out" set
neg "x" get "out" get %fixnum>> ,
] if
] with-template ;
: fast-shift ( n node -- )
over zero? [
-1 %inc-d , 2drop
] [
over 0 < [
negative-shift negative-shift
] [ ] [
drop slow-shift 2drop slow-shift
] if ] if
] if ; ] if ;
\ fixnum-shift [ \ fixnum-shift [
node-peek dup value? [ dup literal-immediate? [
value-literal fast-shift [ node-in-d peek value-literal ] keep fast-shift
] [ ] [
drop slow-shift drop slow-shift
] if ] if

38
library/compiler/linearizer.factor
View File

@ -98,28 +98,29 @@ M: object load-value ( vreg loc value -- operand )
M: value load-value ( vreg loc value -- operand ) M: value load-value ( vreg loc value -- operand )
nip value-literal swap [ [ load-literal ] keep ] when* ; nip value-literal swap [ [ load-literal ] keep ] when* ;
: intrinsic-inputs ( seq template -- inputs ) : (template-inputs) ( seq template -- inputs )
dup length reverse-slice [ <ds-loc> ] map rot 3array flip dup length reverse-slice [ <ds-loc> ] map rot 3array flip
[ first3 load-value ] map ; [ first3 load-value ] map ;
: in-1 ( node -- operand ) : template-inputs ( node template -- )
node-in-d { T{ vreg f 0 } } intrinsic-inputs first ; flip first2 >r [ dup [ <vreg> ] when ] map
>r node-in-d r> (template-inputs)
: in-2 ( node -- operand operand ) r> [ set ] 2each ;
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 -- ) : stacks<>vregs ( values quot quot -- )
>r >r dup reverse-slice swap length r> map r> 2each ; inline >r >r dup reverse-slice swap length r> map r> 2each ; inline
: out-n ( vregs -- ) : template-outputs ( template -- )
[ <ds-loc> ] [ %replace , ] stacks<>vregs ; [ get ] map [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
: out-1 ( vreg -- ) 1array out-n ; : with-template ( node in out quot -- )
[
>r
pick pick template-inputs
dup rot [ length ] 2apply - %inc-d ,
swap node set
r> swap slip template-outputs
] with-scope ; inline
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ; : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
@ -153,16 +154,15 @@ M: #if linearize* ( node -- next )
-1 %inc-d , -1 %inc-d ,
swap node-children nth linearize-child iterate-next swap node-children nth linearize-child iterate-next
] [ ] [
dup in-1 -1 %inc-d , >r <label> dup r> %jump-t , dup { { 0 "flag" } } { } [
linearize-if <label> dup "flag" get %jump-t ,
] with-template linearize-if
] if* ; ] if* ;
: dispatch-head ( node -- label/node ) : dispatch-head ( node -- label/node )
#! Output the jump table insn and return a list of #! Output the jump table insn and return a list of
#! label/branch pairs. #! label/branch pairs.
dup in-1 dup { { 0 "n" } } { } [ "n" get %dispatch , ] with-template
-1 %inc-d ,
%dispatch ,
node-children [ <label> dup %target-label , 2array ] map ; node-children [ <label> dup %target-label , 2array ] map ;
: dispatch-body ( label/node -- ) : dispatch-body ( label/node -- )