97 lines
2.8 KiB
Factor
97 lines
2.8 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: compiler-backend
|
|
USING: alien arrays assembler compiler inference kernel
|
|
kernel-internals lists math memory namespaces sequences words ;
|
|
|
|
! Not used on x86
|
|
M: %prologue generate-node drop ;
|
|
|
|
: compile-dlsym ( symbol dll quot -- )
|
|
>r 2dup dlsym r> call 1 0 rel-dlsym ; inline
|
|
|
|
: compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
|
|
|
|
M: %call generate-node ( vop -- )
|
|
drop label dup postpone-word CALL ;
|
|
|
|
M: %call-label generate-node ( vop -- )
|
|
drop label CALL ;
|
|
|
|
M: %jump generate-node ( vop -- )
|
|
drop label dup postpone-word JMP ;
|
|
|
|
M: %jump-label generate-node ( vop -- )
|
|
drop label JMP ;
|
|
|
|
M: %jump-t generate-node ( vop -- )
|
|
drop
|
|
! Compare input with f
|
|
0 input-operand f address CMP
|
|
! If not equal, jump
|
|
label JNE ;
|
|
|
|
M: %return-to generate-node ( vop -- )
|
|
drop 0 PUSH label absolute-4 ;
|
|
|
|
M: %return generate-node ( vop -- )
|
|
drop RET ;
|
|
|
|
M: %dispatch generate-node ( vop -- )
|
|
#! Compile a piece of code that jumps to an offset in a
|
|
#! jump table indexed by the fixnum at the top of the stack.
|
|
#! The jump table must immediately follow this macro.
|
|
<label> "end" set
|
|
drop
|
|
! Untag and multiply by 4 to get a jump table offset
|
|
0 input-operand tag-bits 2 - SHR
|
|
! Add to jump table base
|
|
0 input-operand HEX: ffff ADD "end" get absolute-4
|
|
! Jump to jump table entry
|
|
0 input-operand 1array JMP
|
|
! Align for better performance
|
|
compile-aligned
|
|
! Fix up jump table pointer
|
|
"end" get save-xt ;
|
|
|
|
M: %type generate-node ( vop -- )
|
|
#! Intrinstic version of type primitive.
|
|
drop
|
|
<label> "header" set
|
|
<label> "f" set
|
|
<label> "end" set
|
|
! Make a copy
|
|
0 scratch 0 output-operand MOV
|
|
! Get the tag
|
|
0 output-operand tag-mask AND
|
|
! Compare with object tag number (3).
|
|
0 output-operand object-tag CMP
|
|
! Jump if the object doesn't store type info in its header
|
|
"header" get JE
|
|
! It doesn't store type info in its header
|
|
0 output-operand tag-bits SHL
|
|
"end" get JMP
|
|
"header" get save-xt
|
|
! It does store type info in its header
|
|
! Is the pointer itself equal to 3? Then its F_TYPE (9).
|
|
0 scratch object-tag CMP
|
|
"f" get JE
|
|
! The pointer is not equal to 3. Load the object header.
|
|
0 output-operand ECX object-tag neg 2array MOV
|
|
! Mask off header tag, making a fixnum.
|
|
0 output-operand object-tag XOR
|
|
"end" get JMP
|
|
"f" get save-xt
|
|
! The pointer is equal to 3. Load F_TYPE (9).
|
|
0 output-operand f type tag-bits shift MOV
|
|
"end" get save-xt ;
|
|
|
|
M: %tag generate-node ( vop -- )
|
|
drop
|
|
0 input-operand tag-mask AND
|
|
0 input-operand tag-bits SHL ;
|
|
|
|
M: %untag generate-node ( vop -- )
|
|
drop
|
|
0 output-operand tag-mask bitnot AND ;
|