all intrinsics tests pass (except overflow)
parent
ceb15dbe5d
commit
eac3146be6
|
@ -30,3 +30,5 @@ M: float-regs fastcall-regs drop 0 ;
|
||||||
: fixnum>slot@ drop ; inline
|
: fixnum>slot@ drop ; inline
|
||||||
|
|
||||||
: return-register RAX ; inline
|
: return-register RAX ; inline
|
||||||
|
|
||||||
|
: remainder-reg RDX ; inline
|
||||||
|
|
|
@ -42,17 +42,19 @@ M: %call-label generate-node ( vop -- )
|
||||||
|
|
||||||
: compile-call ( label -- )
|
: compile-call ( label -- )
|
||||||
#! Far C call for primitives, near C call for compiled defs.
|
#! Far C call for primitives, near C call for compiled defs.
|
||||||
|
dup postpone-word
|
||||||
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
|
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
|
||||||
|
|
||||||
M: %call generate-node ( vop -- )
|
M: %call generate-node ( vop -- )
|
||||||
vop-label dup postpone-word compile-call ;
|
vop-label compile-call ;
|
||||||
|
|
||||||
: compile-jump ( label -- )
|
: compile-jump ( label -- )
|
||||||
#! For tail calls. IP not saved on C stack.
|
#! For tail calls. IP not saved on C stack.
|
||||||
|
dup postpone-word
|
||||||
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
|
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
|
||||||
|
|
||||||
M: %jump generate-node ( vop -- )
|
M: %jump generate-node ( vop -- )
|
||||||
vop-label dup postpone-word compile-epilogue compile-jump ;
|
vop-label compile-epilogue compile-jump ;
|
||||||
|
|
||||||
M: %jump-label generate-node ( vop -- )
|
M: %jump-label generate-node ( vop -- )
|
||||||
vop-label B ;
|
vop-label B ;
|
||||||
|
|
|
@ -30,3 +30,5 @@ M: float-regs fastcall-regs drop 0 ;
|
||||||
: fixnum>slot@ 1 SHR ; inline
|
: fixnum>slot@ 1 SHR ; inline
|
||||||
|
|
||||||
: return-register EAX ; inline
|
: return-register EAX ; inline
|
||||||
|
|
||||||
|
: remainder-reg EDX ; inline
|
||||||
|
|
|
@ -152,6 +152,7 @@ UNION: operand register indirect displaced disp-only ;
|
||||||
GENERIC: PUSH ( op -- )
|
GENERIC: PUSH ( op -- )
|
||||||
M: register PUSH f HEX: 50 short-operand ;
|
M: register PUSH f HEX: 50 short-operand ;
|
||||||
M: integer PUSH HEX: 68 assemble-1 assemble-4 ;
|
M: integer PUSH HEX: 68 assemble-1 assemble-4 ;
|
||||||
|
M: word PUSH 0 PUSH absolute-4 ;
|
||||||
M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
|
M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
|
||||||
|
|
||||||
GENERIC: POP ( op -- )
|
GENERIC: POP ( op -- )
|
||||||
|
@ -165,6 +166,7 @@ M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand assemble-4 ;
|
||||||
|
|
||||||
GENERIC: MOV ( dst src -- )
|
GENERIC: MOV ( dst src -- )
|
||||||
M: integer MOV swap (MOV-I) ;
|
M: integer MOV swap (MOV-I) ;
|
||||||
|
M: word MOV 0 rot (MOV-I) absolute-cell ;
|
||||||
M: operand MOV HEX: 89 2-operand ;
|
M: operand MOV HEX: 89 2-operand ;
|
||||||
|
|
||||||
( Control flow )
|
( Control flow )
|
||||||
|
|
|
@ -28,7 +28,7 @@ math-internals memory namespaces words ;
|
||||||
0 output-operand PUSH
|
0 output-operand PUSH
|
||||||
"s48_long_to_bignum" f compile-c-call
|
"s48_long_to_bignum" f compile-c-call
|
||||||
! An untagged pointer to the bignum is now in EAX; tag it
|
! An untagged pointer to the bignum is now in EAX; tag it
|
||||||
EAX bignum-tag OR
|
return-reg bignum-tag OR
|
||||||
0 scratch POP
|
0 scratch POP
|
||||||
"end" get save-xt ; inline
|
"end" get save-xt ; inline
|
||||||
|
|
||||||
|
@ -42,22 +42,24 @@ M: %fixnum* generate-node ( vop -- )
|
||||||
drop
|
drop
|
||||||
! both inputs are tagged, so one of them needs to have its
|
! both inputs are tagged, so one of them needs to have its
|
||||||
! tag removed.
|
! tag removed.
|
||||||
EAX tag-bits SAR
|
0 input-operand tag-bits SAR
|
||||||
ECX IMUL
|
1 input-operand IMUL
|
||||||
<label> "end" set
|
<label> "end" set
|
||||||
"end" get JNO
|
"end" get JNO
|
||||||
EDX PUSH
|
remainder-reg PUSH
|
||||||
EAX PUSH
|
0 input-operand PUSH
|
||||||
"s48_long_long_to_bignum" f compile-c-call
|
"s48_long_long_to_bignum" f compile-c-call
|
||||||
ESP 8 ADD
|
0 scratch POP
|
||||||
|
1 scratch POP
|
||||||
! now we have to shift it by three bits to remove the second
|
! now we have to shift it by three bits to remove the second
|
||||||
! tag
|
! tag
|
||||||
tag-bits neg PUSH
|
tag-bits neg PUSH
|
||||||
EAX PUSH
|
0 input-operand PUSH
|
||||||
"s48_bignum_arithmetic_shift" f compile-c-call
|
"s48_bignum_arithmetic_shift" f compile-c-call
|
||||||
! an untagged pointer to the bignum is now in EAX; tag it
|
! an untagged pointer to the bignum is now in EAX; tag it
|
||||||
EAX bignum-tag OR
|
return-reg bignum-tag OR
|
||||||
ESP 8 ADD
|
0 scratch POP
|
||||||
|
1 scratch POP
|
||||||
"end" get save-xt ;
|
"end" get save-xt ;
|
||||||
|
|
||||||
M: %fixnum-mod generate-node ( vop -- )
|
M: %fixnum-mod generate-node ( vop -- )
|
||||||
|
@ -65,7 +67,7 @@ M: %fixnum-mod generate-node ( vop -- )
|
||||||
#! EAX and ECX, and the result is in EDX.
|
#! EAX and ECX, and the result is in EDX.
|
||||||
drop
|
drop
|
||||||
CDQ
|
CDQ
|
||||||
ECX IDIV ;
|
1 input-operand IDIV ;
|
||||||
|
|
||||||
: generate-fixnum/mod
|
: generate-fixnum/mod
|
||||||
#! The same code is used for %fixnum/i and %fixnum/mod.
|
#! The same code is used for %fixnum/i and %fixnum/mod.
|
||||||
|
@ -73,24 +75,24 @@ M: %fixnum-mod generate-node ( vop -- )
|
||||||
#! EAX and ECX, and the result is in EDX.
|
#! EAX and ECX, and the result is in EDX.
|
||||||
<label> "end" set
|
<label> "end" set
|
||||||
CDQ
|
CDQ
|
||||||
ECX IDIV
|
1 input-operand IDIV
|
||||||
! Make a copy since following shift is destructive
|
! Make a copy since following shift is destructive
|
||||||
ECX EAX MOV
|
1 input-operand 0 input-operand MOV
|
||||||
! Tag the value, since division cancelled tags from both
|
! Tag the value, since division cancelled tags from both
|
||||||
! inputs
|
! inputs
|
||||||
EAX tag-bits SHL
|
0 input-operand tag-bits SHL
|
||||||
! Did it overflow?
|
! Did it overflow?
|
||||||
"end" get JNO
|
"end" get JNO
|
||||||
! There was an overflow, so make ECX into a bignum. we must
|
! There was an overflow, so make ECX into a bignum. we must
|
||||||
! save EDX since its volatile.
|
! save EDX since its volatile.
|
||||||
EDX PUSH
|
remainder-reg PUSH
|
||||||
ECX PUSH
|
1 input-operand PUSH
|
||||||
"s48_long_to_bignum" f compile-c-call
|
"s48_long_to_bignum" f compile-c-call
|
||||||
! An untagged pointer to the bignum is now in EAX; tag it
|
! An untagged pointer to the bignum is now in EAX; tag it
|
||||||
EAX bignum-tag OR
|
return-reg bignum-tag OR
|
||||||
ESP cell ADD
|
0 scratch POP
|
||||||
! the remainder is now in EDX
|
! the remainder is now in EDX
|
||||||
EDX POP
|
remainder-reg POP
|
||||||
"end" get save-xt ;
|
"end" get save-xt ;
|
||||||
|
|
||||||
M: %fixnum/i generate-node drop generate-fixnum/mod ;
|
M: %fixnum/i generate-node drop generate-fixnum/mod ;
|
||||||
|
|
|
@ -13,13 +13,15 @@ M: %prologue generate-node drop ;
|
||||||
: compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
|
: compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
|
||||||
|
|
||||||
M: %call generate-node ( vop -- )
|
M: %call generate-node ( vop -- )
|
||||||
drop label dup postpone-word CALL ;
|
drop label dup postpone-word
|
||||||
|
dup primitive? [ address-operand ] when CALL ;
|
||||||
|
|
||||||
M: %call-label generate-node ( vop -- )
|
M: %call-label generate-node ( vop -- )
|
||||||
drop label CALL ;
|
drop label CALL ;
|
||||||
|
|
||||||
M: %jump generate-node ( vop -- )
|
M: %jump generate-node ( vop -- )
|
||||||
drop label dup postpone-word JMP ;
|
drop label dup postpone-word
|
||||||
|
dup primitive? [ address-operand ] when JMP ;
|
||||||
|
|
||||||
M: %jump-label generate-node ( vop -- )
|
M: %jump-label generate-node ( vop -- )
|
||||||
drop label JMP ;
|
drop label JMP ;
|
||||||
|
@ -32,7 +34,7 @@ M: %jump-t generate-node ( vop -- )
|
||||||
label JNE ;
|
label JNE ;
|
||||||
|
|
||||||
M: %return-to generate-node ( vop -- )
|
M: %return-to generate-node ( vop -- )
|
||||||
drop 0 PUSH label absolute-cell ;
|
drop label address-operand PUSH ;
|
||||||
|
|
||||||
M: %return generate-node ( vop -- )
|
M: %return generate-node ( vop -- )
|
||||||
drop RET ;
|
drop RET ;
|
||||||
|
|
Loading…
Reference in New Issue