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

Got scratch registers working; PowerPC backend fully operational, x86 in progress

slava 2006-04-29 21:13:02 +00:00
parent 906fea6508
commit f684243e2f
7 changed files with 280 additions and 337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO.FACTOR.txt
View File

@ -1,8 +1,8 @@
should fix in 0.82: should fix in 0.82:
- type inference busted for tuple constructors
- constant branch folding - constant branch folding
- getenv, setenv, fast-slot stuff - fast-slot stuff
- more flexible fixnum intrinsics
- compile if-intrinsic even if there is no #if there - compile if-intrinsic even if there is no #if there
- 3 >n fep - 3 >n fep
- amd64 %box-struct - amd64 %box-struct
@ -13,7 +13,6 @@ should fix in 0.82:
- speed up ideas: - speed up ideas:
- only do clipping for certain gadgets - only do clipping for certain gadgets
- use glRect - use glRect
- cocoa: global menu bar with useful commands
+ portability: + portability:

8
library/compiler/generator/generator.factor
View File

@ -117,7 +117,7 @@ M: #label generate-node ( node -- next )
M: #if generate-node ( node -- next ) M: #if generate-node ( node -- next )
[ [
end-basic-block end-basic-block
<label> dup "flag" get %jump-t <label> dup %jump-t
] H{ ] H{
{ +input { { 0 "flag" } } } { +input { { 0 "flag" } } }
} with-template generate-if ; } with-template generate-if ;
@ -153,8 +153,10 @@ M: #call-label generate-node ( node -- next )
: 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.
[ end-basic-block "n" get %dispatch ] [ end-basic-block %dispatch ] H{
H{ { +input { { 0 "n" } } } } with-template { +input { { f "n" } } }
{ +scratch { { f "scratch" } } }
} with-template
node-children [ <label> dup target-label 2array ] map ; node-children [ <label> dup target-label 2array ] map ;
: dispatch-body ( label/node -- ) : dispatch-body ( label/node -- )

56
library/compiler/generator/templates.factor
View File

@ -4,8 +4,27 @@ IN: compiler
USING: arrays generic hashtables inference io kernel math USING: arrays generic hashtables inference io kernel math
namespaces prettyprint sequences vectors words ; namespaces prettyprint sequences vectors words ;
! Register allocation
SYMBOL: free-vregs SYMBOL: free-vregs
: alloc-reg ( -- n )
free-vregs get pop ;
: alloc-reg# ( n -- regs )
free-vregs [ cut ] change ;
: requested-vregs ( template -- n )
0 [ [ 1+ ] unless ] reduce ;
: template-vreg# ( template template -- n )
[ requested-vregs ] 2apply + ;
: alloc-vregs ( template -- template )
[ first [ alloc-reg ] unless* ] map ;
: adjust-free-vregs ( seq -- )
free-vregs [ diff ] change ;
! A data stack location. ! A data stack location.
TUPLE: ds-loc n ; TUPLE: ds-loc n ;
@ -86,8 +105,6 @@ SYMBOL: phantom-r
: finalize-heights ( -- ) : finalize-heights ( -- )
phantoms [ finalize-height ] 2apply ; phantoms [ finalize-height ] 2apply ;
: alloc-reg ( -- n ) free-vregs get pop ;
: stack>vreg ( vreg# loc -- operand ) : stack>vreg ( vreg# loc -- operand )
>r <vreg> dup r> %peek ; >r <vreg> dup r> %peek ;
@ -143,18 +160,6 @@ SYMBOL: phantom-r
used-vregs vregs length reverse diff used-vregs vregs length reverse diff
>vector free-vregs set ; >vector free-vregs set ;
: requested-vregs ( template -- n )
0 [ [ 1+ ] unless ] reduce ;
: template-vreg# ( template template -- n )
[ requested-vregs ] 2apply + ;
: alloc-regs ( template -- template )
[ [ alloc-reg ] unless* ] map ;
: alloc-reg# ( n -- regs )
free-vregs [ cut ] change ;
: additional-vregs# ( seq seq -- n ) : additional-vregs# ( seq seq -- n )
2array phantoms 2array [ [ length ] map ] 2apply v- 2array phantoms 2array [ [ length ] map ] 2apply v-
0 [ 0 max + ] reduce ; 0 [ 0 max + ] reduce ;
@ -176,8 +181,7 @@ SYMBOL: phantom-r
: stack>vregs ( phantom template -- values ) : stack>vregs ( phantom template -- values )
[ [
[ first ] map alloc-regs alloc-vregs dup length rot phantom-locs
dup length rot phantom-locs
[ stack>vreg ] 2map [ stack>vreg ] 2map
] 2keep length neg swap adjust-phantom ; ] 2keep length neg swap adjust-phantom ;
@ -226,8 +230,6 @@ SYMBOL: +clobber
{ +clobber { } } { +clobber { } }
} swap hash-union ; } swap hash-union ;
: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
: output-vregs ( -- seq seq ) : output-vregs ( -- seq seq )
+output +clobber [ get [ get ] map ] 2apply ; +output +clobber [ get [ get ] map ] 2apply ;
@ -236,7 +238,11 @@ SYMBOL: +clobber
[ swap member? ] contains-with? ; [ swap member? ] contains-with? ;
: slow-input ( template -- ) : slow-input ( template -- )
! Are we loading stuff from the stack? Then flush out
! remaining vregs, not slurped in by fast-input.
dup empty? [ finalize-contents ] unless dup empty? [ finalize-contents ] unless
! Do the outputs clash with vregs on the phantom stacks?
! Then we must flush them first.
outputs-clash? [ finalize-contents ] when outputs-clash? [ finalize-contents ] when
phantom-d get swap [ stack>vregs ] keep phantom-vregs ; phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
@ -244,11 +250,23 @@ SYMBOL: +clobber
+input +scratch [ get [ second get vreg-n ] map ] 2apply +input +scratch [ get [ second get vreg-n ] map ] 2apply
append ; append ;
: guess-vregs ( -- n )
+input get dup { } additional-vregs# +scratch get length + ;
: alloc-scratch ( -- )
+scratch get [ alloc-vregs [ <vreg> ] map ] keep
phantom-vregs ;
: template-inputs ( -- ) : template-inputs ( -- )
+input get dup { } additional-vregs# ensure-vregs ! Ensure we have enough to hold any new stack elements we
! will read (if any), and scratch.
guess-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
match-template fast-input match-template fast-input
used-vregs adjust-free-vregs used-vregs adjust-free-vregs
slow-input slow-input
alloc-scratch
input-vregs adjust-free-vregs ; input-vregs adjust-free-vregs ;
: template-outputs ( -- ) : template-outputs ( -- )

150
library/compiler/intrinsics.factor
View File

@ -1,150 +0,0 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: arrays assembler generic hashtables
inference kernel kernel-internals lists math math-internals
namespaces sequences words ;
\ slot [
[
"obj" get %untag ,
"n" get "obj" get %slot ,
] H{
{ +input { { f "obj" } { f "n" } } }
{ +output { "obj" } }
} with-template
] "intrinsic" set-word-prop
\ set-slot [
[
"obj" get %untag ,
"val" get "obj" get "slot" get %set-slot ,
finalize-contents
"obj" get %write-barrier ,
] H{
{ +input { { f "val" } { f "obj" } { f "slot" } } }
{ +clobber { "obj" } }
} with-template
] "intrinsic" set-word-prop
\ char-slot [
[
"n" get "str" get %char-slot ,
] H{
{ +input { { f "n" } { f "str" } } }
{ +output { "str" } }
} with-template
] "intrinsic" set-word-prop
\ set-char-slot [
[
"ch" get "str" get "n" get %set-char-slot ,
] H{
{ +input { { f "ch" } { f "n" } { f "str" } } }
} with-template
] "intrinsic" set-word-prop
\ type [
[ finalize-contents "in" get %type , ] H{
{ +input { { f "in" } } }
{ +output { "in" } }
} with-template
] "intrinsic" set-word-prop
\ tag [
[ "in" get %tag , ] H{
{ +input { { f "in" } } }
{ +output { "in" } }
} with-template
] "intrinsic" set-word-prop
: binary-op ( op -- )
[
finalize-contents >r "y" get "x" get dup r> execute ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +output { "x" } }
} with-template ; inline
{
{ fixnum+ %fixnum+ }
{ fixnum- %fixnum- }
{ fixnum/i %fixnum/i }
{ fixnum* %fixnum* }
} [
first2 [ binary-op ] curry
"intrinsic" set-word-prop
] each
: binary-op-fast ( op -- )
[
>r "y" get "x" get dup r> execute ,
] H{
{ +input { { f "x" } { f "y" } } }
{ +output { "x" } }
} with-template ; inline
{
{ fixnum-bitand %fixnum-bitand }
{ fixnum-bitor %fixnum-bitor }
{ fixnum-bitxor %fixnum-bitxor }
{ fixnum+fast %fixnum+fast }
{ fixnum-fast %fixnum-fast }
} [
first2 [ binary-op-fast ] curry
"intrinsic" set-word-prop
] each
: binary-jump ( label op -- )
[
end-basic-block >r >r "y" get "x" get r> r> execute ,
] H{
{ +input { { f "x" } { f "y" } } }
} with-template ; inline
{
{ fixnum<= %jump-fixnum<= }
{ fixnum< %jump-fixnum< }
{ fixnum>= %jump-fixnum>= }
{ fixnum> %jump-fixnum> }
{ eq? %jump-eq? }
} [
first2 [ binary-jump ] curry
"if-intrinsic" set-word-prop
] each
\ fixnum-mod [
! 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.
[
finalize-contents
T{ vreg f 2 } "out" set
"y" get "x" get "out" get %fixnum-mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
! { +scratch { { 2 "out" } } }
{ +output { "out" } }
} with-template
] "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
[
finalize-contents
T{ vreg f 2 } "rem" set
"y" get "x" get 2array
"rem" get "x" get 2array %fixnum/mod ,
] H{
{ +input { { 0 "x" } { 1 "y" } } }
! { +scratch { { 2 "rem" } } }
{ +output { "x" "rem" } }
} with-template
] "intrinsic" set-word-prop
\ fixnum-bitnot [
[ "x" get dup %fixnum-bitnot , ] H{
{ +input { { f "x" } } }
{ +output { "x" } }
} with-template
] "intrinsic" set-word-prop

17
library/compiler/ppc/architecture.factor
View File

@ -69,17 +69,18 @@ M: object load-literal ( literal vreg -- )
: %jump ( label -- ) : %jump ( label -- )
%epilogue dup postpone-word %jump-label ; %epilogue dup postpone-word %jump-label ;
: %jump-t ( label vreg -- ) : %jump-t ( label -- )
0 swap v>operand f address CMPI BNE ; 0 "flag" operand f address CMPI BNE ;
: %dispatch ( vreg -- ) : %dispatch ( -- )
v>operand dup dup 1 SRAWI "n" operand dup 1 SRAWI
! The value 24 is a magic number. It is the length of the ! The value 24 is a magic number. It is the length of the
! instruction sequence that follows to be generated. ! instruction sequence that follows to be generated.
compiled-offset 24 + 11 LOAD32 rel-2/2 rel-address compiled-offset 24 + "scratch" operand LOAD32
dup dup 11 ADD rel-2/2 rel-address
dup dup 0 LWZ "n" operand dup "scratch" operand ADD
MTLR "n" operand dup 0 LWZ
"n" operand MTLR
BLR ; BLR ;
: %return ( -- ) %epilogue BLR ; : %return ( -- ) %epilogue BLR ;

364
library/compiler/ppc/intrinsics.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: compiler IN: compiler
USING: assembler kernel kernel-internals math math-internals USING: alien assembler kernel kernel-internals math
namespaces sequences ; math-internals namespaces sequences words ;
: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ; : untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
@ -11,11 +11,12 @@ namespaces sequences ;
: untag-fixnum ( src dest -- ) tag-bits SRAWI ; : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
\ tag [ \ tag [
"in" operand dup tag-mask ANDI "in" operand "out" operand tag-mask ANDI
"in" operand dup tag-fixnum "out" operand dup tag-fixnum
] H{ ] H{
{ +input { { f "in" } } } { +input { { f "in" } } }
{ +output { "in" } } { +scratch { { f "out" } } }
{ +output { "out" } }
} define-intrinsic } define-intrinsic
: generate-slot ( size quot -- ) : generate-slot ( size quot -- )
@ -43,6 +44,42 @@ namespaces sequences ;
{ +output { "obj" } } { +output { "obj" } }
} define-intrinsic } define-intrinsic
: generate-set-slot ( size quot -- )
>r >r
! turn tagged fixnum slot # into an offset, multiple of 4
"slot" operand dup tag-bits r> - SRAWI
! compute slot address in 1st input
"slot" operand dup "obj" operand ADD
! store new slot value
"val" operand "slot" operand r> call ; inline
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"obj" operand dup card-bits SRAWI
"obj" operand dup 16 ADD
"x" operand "obj" operand 0 LBZ
"x" operand dup card-mark ORI
"x" operand "obj" operand 0 STB ;
\ set-slot [
"obj" operand dup untag
cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
] H{
{ +input { { f "val" } { f "obj" } { f "slot" } } }
{ +scratch { { f "x" } } }
{ +clobber { "obj" } }
} define-intrinsic
\ set-char-slot [
! untag the new value in 0th input
"val" operand dup untag-fixnum
1 [ string-offset STH ] generate-set-slot
] H{
{ +input { { f "val" } { f "slot" } { f "obj" } } }
{ +scratch { { f "x" } } }
{ +clobber { "obj" } }
} define-intrinsic
: define-binary-op ( word op -- ) : define-binary-op ( word op -- )
[ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{ [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
{ +input { { f "x" } { f "y" } } } { +input { { f "x" } { f "y" } } }
@ -59,6 +96,23 @@ namespaces sequences ;
first2 define-binary-op first2 define-binary-op
] each ] each
: generate-fixnum-mod
#! PowerPC doesn't have a MOD instruction; so we compute
#! x-(x/y)*y. Puts the result in "s" operand.
"s" operand "r" operand "y" operand MULLW
"s" operand "s" operand "x" operand SUBF ;
\ fixnum-mod [
! divide x by y, store result in x
"r" operand "x" operand "y" operand DIVW
generate-fixnum-mod
"x" operand "s" operand MR
] H{
{ +input { { f "x" } { f "y" } } }
{ +scratch { { f "r" } { f "s" } } }
{ +output { "x" } }
} define-intrinsic
\ fixnum-bitnot [ \ fixnum-bitnot [
"x" operand dup NOT "x" operand dup NOT
"x" operand dup untag "x" operand dup untag
@ -83,143 +137,163 @@ namespaces sequences ;
first2 define-binary-jump first2 define-binary-jump
] each ] each
! M: %type generate-node ( vop -- ) \ type [
! drop <label> "f" set
! <label> "f" set <label> "end" set
! <label> "end" set ! Get the tag
! ! Get the tag "obj" operand "y" operand tag-mask ANDI
! 0 input-operand 1 scratch tag-mask ANDI ! Tag the tag
! ! Tag the tag "y" operand "x" operand tag-fixnum
! 1 scratch 0 scratch tag-fixnum ! Compare with object tag number (3).
! ! Compare with object tag number (3). 0 "y" operand object-tag CMPI
! 0 1 scratch object-tag CMPI ! Jump if the object doesn't store type info in its header
! ! Jump if the object doesn't store type info in its header "end" get BNE
! "end" get BNE ! It does store type info in its header
! ! It does store type info in its header ! Is the pointer itself equal to 3? Then its F_TYPE (9).
! ! Is the pointer itself equal to 3? Then its F_TYPE (9). 0 "obj" operand object-tag CMPI
! 0 0 input-operand object-tag CMPI "f" get BEQ
! "f" get BEQ ! The pointer is not equal to 3. Load the object header.
! ! The pointer is not equal to 3. Load the object header. "x" operand "obj" operand object-tag neg LWZ
! 0 scratch 0 input-operand object-tag neg LWZ "x" operand dup untag
! 0 scratch dup untag "end" get B
! "end" get B "f" get save-xt
! "f" get save-xt ! The pointer is equal to 3. Load F_TYPE (9).
! ! The pointer is equal to 3. Load F_TYPE (9). f type tag-bits shift "x" operand LI
! f type tag-bits shift 0 scratch LI "end" get save-xt
! "end" get save-xt ] H{
! 0 output-operand 0 scratch MR ; { +input { { f "obj" } } }
! { +scratch { { f "x" } { f "y" } } }
! : generate-set-slot ( size quot -- ) { +output { "x" } }
! >r >r } define-intrinsic
! ! turn tagged fixnum slot # into an offset, multiple of 4
! 2 input-operand dup tag-bits r> - SRAWI : simple-overflow ( word -- )
! ! compute slot address in 1st input >r
! 2 input-operand dup 1 input-operand ADD <label> "end" set
! ! store new slot value "end" get BNO
! 0 input-operand 2 input-operand r> call ; inline { "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
! 3 "y" operand "x" operand r> execute
! M: %set-slot generate-node ( vop -- ) "s48_long_to_bignum" f %alien-invoke
! drop cell log2 [ 0 STW ] generate-set-slot ; ! An untagged pointer to the bignum is now in r3; tag it
! 3 "r" operand bignum-tag ORI
! M: %write-barrier generate-node ( vop -- ) "end" get save-xt ; inline
! #! Mark the card pointed to by vreg.
! drop \ fixnum+ [
! 0 input-operand dup card-bits SRAWI finalize-contents
! 0 input-operand dup 16 ADD 0 MTXER
! 0 scratch 0 input-operand 0 LBZ "r" operand "y" operand "x" operand ADDO.
! 0 scratch dup card-mark ORI \ ADD simple-overflow
! 0 scratch 0 input-operand 0 STB ; ] H{
! { +input { { f "x" } { f "y" } } }
! : simple-overflow ( inv word -- ) { +scratch { { f "r" } } }
! >r >r { +output { "r" } }
! <label> "end" set } define-intrinsic
! "end" get BNO
! >3-vop< r> execute \ fixnum- [
! 0 input-operand dup untag-fixnum finalize-contents
! 1 input-operand dup untag-fixnum 0 MTXER
! >3-vop< r> execute "r" operand "y" operand "x" operand SUBFO.
! "s48_long_to_bignum" f compile-c-call \ SUBF simple-overflow
! ! An untagged pointer to the bignum is now in r3; tag it ] H{
! 0 output-operand dup bignum-tag ORI { +input { { f "x" } { f "y" } } }
! "end" get save-xt ; inline { +scratch { { f "r" } } }
! { +output { "r" } }
! M: %fixnum+ generate-node ( vop -- ) } define-intrinsic
! drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
! : ?MR 2dup = [ 2drop ] [ MR ] if ;
! M: %fixnum- generate-node ( vop -- )
! drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ; \ fixnum* [
! finalize-contents
! M: %fixnum* generate-node ( vop -- ) <label> "end" set
! #! Note that this assumes the output will be in r3. "r" operand "x" operand untag-fixnum
! drop 0 MTXER
! <label> "end" set 11 "y" operand "r" operand MULLWO.
! 1 input-operand dup untag-fixnum "end" get BNO
! 0 MTXER 4 "y" operand "r" operand MULHW
! 0 scratch 0 input-operand 1 input-operand MULLWO. 3 11 ?MR
! "end" get BNO "s48_fixnum_pair_to_bignum" f %alien-invoke
! 1 scratch 0 input-operand 1 input-operand MULHW ! now we have to shift it by three bits to remove the second
! 4 1 scratch MR ! tag
! 3 0 scratch MR tag-bits neg 4 LI
! "s48_fixnum_pair_to_bignum" f compile-c-call "s48_bignum_arithmetic_shift" f %alien-invoke
! ! now we have to shift it by three bits to remove the second ! An untagged pointer to the bignum is now in r3; tag it
! ! tag 3 11 bignum-tag ORI
! tag-bits neg 4 LI "end" get save-xt
! "s48_bignum_arithmetic_shift" f compile-c-call "s" operand 11 MR
! ! An untagged pointer to the bignum is now in r3; tag it ] H{
! 0 output-operand 0 scratch bignum-tag ORI { +input { { f "x" } { f "y" } } }
! "end" get save-xt { +scratch { { f "r" } { f "s" } } }
! 0 output-operand 0 scratch MR ; { +output { "s" } }
! } define-intrinsic
! : generate-fixnum/i
! #! This VOP is funny. If there is an overflow, it falls : generate-fixnum/i
! #! through to the end, and the result is in 0 output-operand. #! This VOP is funny. If there is an overflow, it falls
! #! Otherwise it jumps to the "no-overflow" label and the #! through to the end, and the result is in "x" operand.
! #! result is in 0 scratch. #! Otherwise it jumps to the "no-overflow" label and the
! 0 scratch 1 input-operand 0 input-operand DIVW #! result is in "r" operand.
! ! if the result is greater than the most positive fixnum, <label> "end" set
! ! which can only ever happen if we do <label> "no-overflow" set
! ! most-negative-fixnum -1 /i, then the result is a bignum. "r" operand "x" operand "y" operand DIVW
! <label> "end" set ! if the result is greater than the most positive fixnum,
! <label> "no-overflow" set ! which can only ever happen if we do
! most-positive-fixnum 1 scratch LOAD ! most-negative-fixnum -1 /i, then the result is a bignum.
! 0 scratch 0 1 scratch CMP most-positive-fixnum "s" operand LOAD
! "no-overflow" get BLE "r" operand 0 "s" operand CMP
! most-negative-fixnum neg 3 LOAD "no-overflow" get BLE
! "s48_long_to_bignum" f compile-c-call most-negative-fixnum neg 3 LOAD
! 3 dup bignum-tag ORI ; "s48_long_to_bignum" f %alien-invoke
! "x" operand 3 bignum-tag ORI ;
! M: %fixnum/i generate-node ( vop -- )
! #! This has specific vreg requirements. \ fixnum/i [
! drop finalize-contents
! generate-fixnum/i generate-fixnum/i
! "end" get B "end" get B
! "no-overflow" get save-xt "no-overflow" get save-xt
! 0 scratch 0 output-operand tag-fixnum "r" operand "x" operand tag-fixnum
! "end" get save-xt ; "end" get save-xt
! ] H{
! : generate-fixnum-mod { +input { { f "x" } { f "y" } } }
! #! PowerPC doesn't have a MOD instruction; so we compute { +scratch { { f "r" } { f "s" } } }
! #! x-(x/y)*y. Puts the result in 1 scratch. { +output { "x" } }
! 1 scratch 0 scratch 0 input-operand MULLW } define-intrinsic
! 1 scratch 1 scratch 1 input-operand SUBF ;
! \ fixnum/mod [
! M: %fixnum-mod generate-node ( vop -- ) finalize-contents
! drop generate-fixnum/i
! ! divide in2 by in1, store result in out1 0 "s" operand LI
! 0 scratch 1 input-operand 0 input-operand DIVW "end" get B
! generate-fixnum-mod "no-overflow" get save-xt
! 0 output-operand 1 scratch MR ; generate-fixnum-mod
! "r" operand "x" operand tag-fixnum
! M: %fixnum/mod generate-node ( vop -- ) "end" get save-xt
! #! This has specific vreg requirements. Note: if there's an ] H{
! #! overflow, (most-negative-fixnum 1 /mod) the modulus is { +input { { f "x" } { f "y" } } }
! #! always zero. { +scratch { { f "r" } { f "s" } } }
! drop { +output { "x" "s" } }
! generate-fixnum/i } define-intrinsic
! 0 0 output-operand LI
! "end" get B : userenv ( reg -- )
! "no-overflow" get save-xt #! Load the userenv pointer in a register.
! generate-fixnum-mod "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
! 0 scratch 1 output-operand tag-fixnum
! 0 output-operand 1 scratch MR \ getenv [
! "end" get save-xt ; "n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"x" operand dup 0 LWZ
] H{
{ +input { { f "n" } } }
{ +scratch { { f "x" } } }
{ +output { "x" } }
{ +clobber { "n" } }
} define-intrinsic
\ setenv [
"n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"val" operand "x" operand 0 STW
] H{
{ +input { { f "val" } { f "n" } } }
{ +scratch { { f "x" } } }
{ +clobber { "n" } }
} define-intrinsic

17
library/compiler/x86/architecture.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: compiler IN: compiler
USING: alien arrays assembler generic kernel kernel-internals USING: alien arrays assembler generic kernel kernel-internals
math sequences words ; math namespaces sequences words ;
! x86 register assignments ! x86 register assignments
! EAX, ECX, EDX vregs ! EAX, ECX, EDX vregs
@ -59,24 +59,23 @@ M: object load-literal ( dest literal -- )
: %jump-label ( label -- ) JMP ; : %jump-label ( label -- ) JMP ;
: %jump-t ( label vreg -- ) : %jump-t ( label -- )
v>operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JNE ;
: %dispatch ( vreg -- ) : %dispatch ( -- )
#! Compile a piece of code that jumps to an offset in a #! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the fixnum at the top of the stack. #! jump table indexed by the fixnum at the top of the stack.
#! The jump table must immediately follow this macro. #! The jump table must immediately follow this macro.
drop
<label> "end" set <label> "end" set
! Untag and multiply to get a jump table offset ! Untag and multiply to get a jump table offset
dup fixnum>slot@ "n" operand fixnum>slot@
! Add to jump table base. We use a temporary register since ! Add to jump table base. We use a temporary register since
! on AMD4 we have to load a 64-bit immediate. On x86, this ! on AMD4 we have to load a 64-bit immediate. On x86, this
! is redundant. ! is redundant.
0 scratch HEX: ffffffff MOV "end" get absolute-cell "scratch" get HEX: ffffffff MOV "end" get absolute-cell
dup 0 scratch ADD "n" operand "scratch" get ADD
! Jump to jump table entry ! Jump to jump table entry
dup [] JMP "n" operand [] JMP
! Align for better performance ! Align for better performance
compile-aligned compile-aligned
! Fix up jump table pointer ! Fix up jump table pointer