all intrinsics tests pass (except overflow)

cvs
Slava Pestov 2005-12-07 03:39:05 +00:00
parent ceb15dbe5d
commit eac3146be6
6 changed files with 35 additions and 23 deletions

View File

@ -30,3 +30,5 @@ M: float-regs fastcall-regs drop 0 ;
: fixnum>slot@ drop ; inline
: return-register RAX ; inline
: remainder-reg RDX ; inline

View File

@ -42,17 +42,19 @@ M: %call-label generate-node ( vop -- )
: compile-call ( label -- )
#! Far C call for primitives, near C call for compiled defs.
dup postpone-word
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
M: %call generate-node ( vop -- )
vop-label dup postpone-word compile-call ;
vop-label compile-call ;
: compile-jump ( label -- )
#! For tail calls. IP not saved on C stack.
dup postpone-word
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
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 -- )
vop-label B ;

View File

@ -30,3 +30,5 @@ M: float-regs fastcall-regs drop 0 ;
: fixnum>slot@ 1 SHR ; inline
: return-register EAX ; inline
: remainder-reg EDX ; inline

View File

@ -152,6 +152,7 @@ UNION: operand register indirect displaced disp-only ;
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;
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 ;
GENERIC: POP ( op -- )
@ -165,6 +166,7 @@ M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand assemble-4 ;
GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ;
M: word MOV 0 rot (MOV-I) absolute-cell ;
M: operand MOV HEX: 89 2-operand ;
( Control flow )

View File

@ -28,7 +28,7 @@ math-internals memory namespaces words ;
0 output-operand PUSH
"s48_long_to_bignum" f compile-c-call
! An untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
return-reg bignum-tag OR
0 scratch POP
"end" get save-xt ; inline
@ -42,22 +42,24 @@ M: %fixnum* generate-node ( vop -- )
drop
! both inputs are tagged, so one of them needs to have its
! tag removed.
EAX tag-bits SAR
ECX IMUL
0 input-operand tag-bits SAR
1 input-operand IMUL
<label> "end" set
"end" get JNO
EDX PUSH
EAX PUSH
remainder-reg PUSH
0 input-operand PUSH
"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
! tag
tag-bits neg PUSH
EAX PUSH
0 input-operand PUSH
"s48_bignum_arithmetic_shift" f compile-c-call
! an untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP 8 ADD
return-reg bignum-tag OR
0 scratch POP
1 scratch POP
"end" get save-xt ;
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.
drop
CDQ
ECX IDIV ;
1 input-operand IDIV ;
: generate-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.
<label> "end" set
CDQ
ECX IDIV
1 input-operand IDIV
! 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
! inputs
EAX tag-bits SHL
0 input-operand tag-bits SHL
! Did it overflow?
"end" get JNO
! There was an overflow, so make ECX into a bignum. we must
! save EDX since its volatile.
EDX PUSH
ECX PUSH
remainder-reg PUSH
1 input-operand PUSH
"s48_long_to_bignum" f compile-c-call
! An untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP cell ADD
return-reg bignum-tag OR
0 scratch POP
! the remainder is now in EDX
EDX POP
remainder-reg POP
"end" get save-xt ;
M: %fixnum/i generate-node drop generate-fixnum/mod ;

View File

@ -13,13 +13,15 @@ M: %prologue generate-node drop ;
: compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
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 -- )
drop label CALL ;
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 -- )
drop label JMP ;
@ -32,7 +34,7 @@ M: %jump-t generate-node ( vop -- )
label JNE ;
M: %return-to generate-node ( vop -- )
drop 0 PUSH label absolute-cell ;
drop label address-operand PUSH ;
M: %return generate-node ( vop -- )
drop RET ;