kernel-internals math namespaces sequences ;
! AMD64 register assignments
-! RAX RCX RDX RSI RDI R8 R9 R10 R11 vregs
+! RAX RCX RDX RSI RDI R8 R9 R10 R11 integer vregs
+! XMM0 - XMM7 float vregs
! R13 cards_offset
! R14 datastack
! R15 callstack
: cs-reg R15 ; inline
: remainder-reg RDX ; inline
-: vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
-
M: int-regs return-reg drop RAX ;
-
-M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
+M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
: compile-c-call ( symbol dll -- )
2dup dlsym R10 swap MOV
swap [ MOV ] 2each compile-c-call ;
M: float-regs return-reg drop XMM0 ;
-
-M: float-regs fastcall-regs
- drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+M: float-regs fastcall-regs vregs ;
: address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
! A scratch register for computations
TUPLE: vreg n ;
+C: vreg ( n reg-class -- vreg )
+ [ set-delegate ] keep [ set-vreg-n ] keep ;
+
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs size ;
+: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
+
! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ;
GENERIC: fastcall-regs ( register-class -- regs )
! Sequence mapping vreg-n to native assembler registers
-DEFER: vregs ( -- regs )
+GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect)
G: load-literal ( obj vreg -- ) 1 standard-combination ;
macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
GENERIC: v>operand
-
M: integer v>operand tag-bits shift ;
-
-M: vreg v>operand vreg-n vregs nth ;
-
+M: vreg v>operand dup vreg-n swap vregs nth ;
M: f v>operand address ;
: if>boolean-intrinsic ( label -- )
<label> "end" set
- f T{ vreg f 0 } load-literal
+ f 0 <int-vreg> load-literal
"end" get %jump-label
save-xt
- t T{ vreg f 0 } load-literal
+ t 0 <int-vreg> load-literal
"end" get save-xt
- T{ vreg f 0 } phantom-d get phantom-push ;
+ 0 <int-vreg> phantom-d get phantom-push ;
: do-if-intrinsic ( node -- next )
[ <label> dup ] keep if-intrinsic call
: generate-push ( node -- )
>#push< dup length dup ensure-vregs
- alloc-reg# [ <vreg> ] map
+ alloc-reg# [ <int-vreg> ] map
[ [ load-literal ] 2each ] keep
phantom-d get phantom-append ;
phantoms [ finalize-height ] 2apply ;
: stack>vreg ( vreg# loc -- operand )
- >r <vreg> dup r> %peek ;
+ >r <int-vreg> dup r> %peek ;
: stack>new-vreg ( loc -- vreg )
alloc-reg swap stack>vreg ;
phantoms append [ vreg? ] subset [ vreg-n ] map ;
: compute-free-vregs ( -- )
- used-vregs vregs length reverse diff
+ used-vregs T{ int-regs } vregs length reverse diff
>vector free-vregs set ;
: additional-vregs# ( seq seq -- n )
+input get { } additional-vregs# +scratch get length + ;
: alloc-scratch ( -- )
- +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+ +scratch get [ alloc-vregs [ <int-vreg> ] map ] keep
phantom-vregs ;
: template-inputs ( -- )
node-classes ?hash [ object ] unless* ;
: node-class# ( node n -- class )
- swap [ node-in-d reverse-slice nth ] keep node-class ;
+ swap [ node-in-d reverse-slice ?nth ] keep node-class ;
! Variables used by the class inferencer
! r14 data stack
! r15 call stack
-: vregs { 3 4 5 6 7 8 9 10 } ; inline
-
M: int-regs return-reg drop 3 ;
M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
11 [ compile-dlsym ] keep MTLR BLRL ;
: %alien-callback ( quot -- )
- T{ vreg f 0 } load-literal "run_callback" f %alien-invoke ;
+ 0 <int-vreg> load-literal "run_callback" f %alien-invoke ;
: save-return 0 swap [ return-reg ] keep freg>stack ;
: load-return 0 swap [ return-reg ] keep stack>freg ;
drop-return-reg ;
: %alien-callback ( quot -- )
- T{ vreg f 0 } load-literal
+ 0 <int-vreg> load-literal
EAX PUSH
"run_callback" f %alien-invoke
EAX POP ;
IN: compiler
! x86 register assignments
-! EAX, ECX, EDX vregs
+! EAX, ECX, EDX integer vregs
+! XMM0 - XMM7 float vregs
! ESI datastack
! EBX callstack
-! AMD64 redefines these four
+! AMD64 redefines a lot of words in this file
+
: ds-reg ESI ; inline
: cs-reg EBX ; inline
: remainder-reg EDX ; inline
-: vregs { EAX ECX EDX } ; inline
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-
M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
: %alien-invoke ( symbol dll -- )
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs fastcall-regs drop { } ;
+M: int-regs vregs drop { EAX ECX EDX } ;
M: float-regs fastcall-regs drop { } ;
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: address-operand ( address -- operand )
#! On x86, we can always use an address as an operand
math-internals namespaces sequences words ;
IN: compiler
+! Type checks
\ tag [
"in" operand tag-mask AND
"in" operand tag-bits SHL
{ +output { "obj" } }
} define-intrinsic
+! Slots
: untag ( reg -- ) tag-mask bitnot AND ;
\ slot [
{ +clobber { "val" "slot" "obj" } }
} define-intrinsic
-: define-binary-op ( word op -- )
+! Fixnums
+: define-fixnum-op ( word op -- )
[ [ "x" operand "y" operand ] % , ] [ ] make H{
{ +input { { f "x" } { f "y" } } }
{ +output { "x" } }
{ fixnum-bitor OR }
{ fixnum-bitxor XOR }
} [
- first2 define-binary-op
+ first2 define-fixnum-op
] each
\ fixnum-bitnot [
{ +clobber { "x" "y" } }
} define-intrinsic
-: define-binary-jump ( word op -- )
+: define-fixnum-jump ( word op -- )
[
[ end-basic-block "x" operand "y" operand CMP ] % ,
] [ ] make H{
{ fixnum>= JGE }
{ eq? JE }
} [
- first2 define-binary-jump
+ first2 define-fixnum-jump
] each
+! User environment
: %userenv ( -- )
"x" operand "userenv" f dlsym MOV
0 rel-absolute-cell rel-userenv
IN: temporary
-USING: alien compiler errors inference io kernel math memory
-namespaces test threads ;
+USING: alien compiler errors inference io kernel kernel-internals
+math memory namespaces test threads ;
: callback-1 "void" { } [ ] alien-callback ; compiled