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 : fixnum>slot@ drop ; inline
: return-register RAX ; inline : return-register RAX ; inline
: remainder-reg RDX ; inline

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;