Compiled code labels are now first-class
slava
parent
251f12448f
commit
00d970cf15
|
|
@ -42,17 +42,23 @@ UNION: #terminal
|
|||
|
||||
: init-generator ( -- )
|
||||
V{ } clone relocation-table set
|
||||
V{ } clone literal-table set ;
|
||||
V{ } clone literal-table set
|
||||
V{ } clone label-table set
|
||||
V{ } clone label-relocation-table set ;
|
||||
|
||||
: generate-1 ( word node quot -- | quot: node -- )
|
||||
[
|
||||
#! Generate the code, then dump five vectors to pass to
|
||||
#! add-compiled-block.
|
||||
pick f save-xt [
|
||||
init-generator
|
||||
init-templates
|
||||
generate-code
|
||||
relocation-table get
|
||||
literal-table get
|
||||
label-table get
|
||||
label-relocation-table get
|
||||
] V{ } make
|
||||
code-format 2swap add-compiled-block swap save-xt ;
|
||||
code-format add-compiled-block save-xt ;
|
||||
|
||||
SYMBOL: generate-queue
|
||||
|
||||
|
|
@ -90,9 +96,6 @@ M: node generate-node ( node -- next ) drop iterate-next ;
|
|||
tail-call? [ %jump f ] [ %call iterate-next ] if ;
|
||||
|
||||
M: #label generate-node ( node -- next )
|
||||
#! We remap the IR node's label to a new label object here,
|
||||
#! to avoid problems with two IR #label nodes having the
|
||||
#! same label in different lexical scopes.
|
||||
dup node-param dup generate-call >r
|
||||
swap node-child generate-word r> ;
|
||||
|
||||
|
|
@ -103,8 +106,8 @@ M: #label generate-node ( node -- next )
|
|||
: generate-if ( node label -- next )
|
||||
<label> [
|
||||
>r >r node-children first2 generate-nodes
|
||||
r> r> end-false-branch save-xt generate-nodes
|
||||
] keep save-xt iterate-next ;
|
||||
r> r> end-false-branch resolve-label generate-nodes
|
||||
] keep resolve-label iterate-next ;
|
||||
|
||||
M: #if generate-node ( node -- next )
|
||||
[
|
||||
|
|
@ -125,12 +128,12 @@ M: #if generate-node ( node -- next )
|
|||
[with-template] "if-intrinsic" set-word-prop ;
|
||||
|
||||
: if>boolean-intrinsic ( label -- )
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
f 0 <int-vreg> load-literal
|
||||
"end" get %jump-label
|
||||
save-xt
|
||||
resolve-label
|
||||
t 0 <int-vreg> load-literal
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
0 <int-vreg> phantom-d get phantom-push
|
||||
compute-free-vregs ;
|
||||
|
||||
|
|
@ -154,7 +157,7 @@ M: #call-label generate-node ( node -- next )
|
|||
node-param generate-call ;
|
||||
|
||||
! #dispatch
|
||||
: target-label ( label -- ) 0 , rel-absolute-cell rel-word ;
|
||||
: target-label ( label -- ) 0 , rel-absolute-cell rel-label ;
|
||||
|
||||
: dispatch-head ( node -- label/node )
|
||||
#! Output the jump table insn and return a list of
|
||||
|
|
@ -167,9 +170,9 @@ M: #call-label generate-node ( node -- next )
|
|||
|
||||
: dispatch-body ( label/node -- )
|
||||
<label> swap [
|
||||
first2 save-xt generate-nodes end-basic-block
|
||||
first2 resolve-label generate-nodes end-basic-block
|
||||
dup %jump-label
|
||||
] each save-xt ;
|
||||
] each resolve-label ;
|
||||
|
||||
M: #dispatch generate-node ( node -- next )
|
||||
#! The parameter is a list of nodes, each one is a branch to
|
||||
|
|
@ -220,9 +223,10 @@ M: #shuffle generate-node ( #shuffle -- )
|
|||
! #return
|
||||
M: #return generate-node drop end-basic-block %return f ;
|
||||
|
||||
! These constants must match native/card.h
|
||||
! These constants must match vm/memory.h
|
||||
: card-bits 7 ;
|
||||
: card-mark HEX: 80 ;
|
||||
|
||||
! These constants must match vm/layouts.h
|
||||
: float-offset 8 float-tag - ;
|
||||
: string-offset 3 cells object-tag - ;
|
||||
|
|
|
|||
|
|
@ -5,27 +5,31 @@ USING: arrays assembler errors generic hashtables kernel
|
|||
kernel-internals math namespaces prettyprint queues
|
||||
sequences strings vectors words ;
|
||||
|
||||
: <label> ( -- label )
|
||||
#! Make a label.
|
||||
gensym dup t "label" set-word-prop ;
|
||||
: compiled ( -- n ) building get length code-format * ;
|
||||
|
||||
: label? ( obj -- ? )
|
||||
dup word? [ "label" word-prop ] [ drop f ] if ;
|
||||
TUPLE: label # offset ;
|
||||
|
||||
SYMBOL: label-table
|
||||
|
||||
: push-label ( label -- )
|
||||
label-table get 2dup memq?
|
||||
[ 2drop ] [ dup length pick set-label-# push ] if ;
|
||||
|
||||
C: label ( -- label ) ;
|
||||
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: resolve-label ( label -- )
|
||||
compiled swap set-label-offset ;
|
||||
|
||||
! We use a hashtable "compiled-xts" that maps words to
|
||||
! xt's that are currently being compiled. The commit-xt's word
|
||||
! sets the xt of each word in the hashtable to the value in the
|
||||
! hastable.
|
||||
SYMBOL: compiled-xts
|
||||
|
||||
: save-xt ( xt word -- ) compiled-xts get set-hash ;
|
||||
: save-xt ( word -- )
|
||||
compiled swap compiled-xts get set-hash ;
|
||||
|
||||
: commit-xts ( -- )
|
||||
compiled-xts get [ swap set-word-xt ] hash-each ;
|
||||
|
||||
: compiled-xt ( word -- xt )
|
||||
dup compiled-xts get hash [ ] [ word-xt ] ?if ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- n )
|
||||
|
|
@ -36,8 +40,7 @@ SYMBOL: literal-table
|
|||
] if ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
|
||||
: rel, ( n -- ) relocation-table get push ;
|
||||
SYMBOL: label-relocation-table
|
||||
|
||||
: rel-absolute-cell 0 ;
|
||||
: rel-absolute 1 ;
|
||||
|
|
@ -47,29 +50,36 @@ SYMBOL: relocation-table
|
|||
: rel-relative-2 5 ;
|
||||
: rel-relative-3 6 ;
|
||||
|
||||
: compiled ( -- n ) building get length code-format * ;
|
||||
|
||||
: rel-type, ( arg class type -- )
|
||||
: (rel) ( arg class type -- { m n } )
|
||||
#! Write a relocation instruction for the runtime image
|
||||
#! loader.
|
||||
over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
|
||||
compiled r> rel-absolute-cell = cell 4 ? - rel, ;
|
||||
over >r >r >r 16 shift r> 8 shift bitor r> bitor
|
||||
compiled r> rel-absolute-cell = cell 4 ? - 2array ;
|
||||
|
||||
: rel, ( arg class type -- )
|
||||
(rel) relocation-table get nappend ;
|
||||
|
||||
: label, ( arg class type -- )
|
||||
(rel) label-relocation-table get nappend ;
|
||||
|
||||
: rel-dlsym ( name dll class -- )
|
||||
>r 2array add-literal r> 1 rel-type, ;
|
||||
>r 2array add-literal r> 1 rel, ;
|
||||
|
||||
: rel-here ( class -- )
|
||||
dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
|
||||
dup rel-relative = [ drop ] [ 0 swap 2 rel, ] if ;
|
||||
|
||||
: rel-word ( word class -- )
|
||||
over primitive?
|
||||
[ >r word-primitive r> 0 ] [ >r add-literal r> 5 ] if
|
||||
rel-type, ;
|
||||
rel, ;
|
||||
|
||||
: rel-cards ( class -- ) 0 swap 3 rel-type, ;
|
||||
: rel-cards ( class -- ) 0 swap 3 rel, ;
|
||||
|
||||
: rel-literal ( literal class -- )
|
||||
>r add-literal r> 4 rel-type, ;
|
||||
>r add-literal r> 4 rel, ;
|
||||
|
||||
: rel-label ( label class -- )
|
||||
>r dup push-label label-# r> 5 label, ;
|
||||
|
||||
! When a word is encountered that has not been previously
|
||||
! compiled, it is pushed onto this vector. Compilation stops
|
||||
|
|
@ -80,9 +90,8 @@ SYMBOL: compile-words
|
|||
#! A word that is compiling or already compiled will not be
|
||||
#! added to the list of words to be compiled.
|
||||
dup compiled?
|
||||
over label? or
|
||||
over compile-words get member? or
|
||||
swap compiled-xts get hash or ;
|
||||
swap compiled-xts get hash-member? or ;
|
||||
|
||||
: with-compiler ( quot -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -289,7 +289,7 @@ sequences strings vectors words prettyprint ;
|
|||
\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
|
||||
\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ add-compiled-block [ [ vector integer vector vector ] [ integer ] ] "infer-effect" set-word-prop
|
||||
\ add-compiled-block [ [ vector vector vector vector integer ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
|
||||
\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -162,12 +162,14 @@ words ;
|
|||
G: (B) ( dest aa lk -- ) 2 standard-combination ;
|
||||
M: integer (B) i-form 18 insn ;
|
||||
M: word (B) 0 -rot (B) rel-relative-3 rel-word ;
|
||||
M: label (B) 0 -rot (B) rel-relative-3 rel-label ;
|
||||
|
||||
: B 0 0 (B) ; : BL 0 1 (B) ;
|
||||
|
||||
GENERIC: BC
|
||||
M: integer BC 0 0 b-form 16 insn ;
|
||||
M: word BC >r 0 BC r> rel-relative-2 rel-word ;
|
||||
M: label BC >r 0 BC r> rel-relative-2 rel-label ;
|
||||
|
||||
: BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
|
||||
: BGT 12 1 rot BC ; : BLE 4 1 rot BC ;
|
||||
|
|
|
|||
|
|
@ -129,14 +129,14 @@ math-internals namespaces sequences words ;
|
|||
|
||||
: simple-overflow ( word -- )
|
||||
>r
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
"end" get BNO
|
||||
{ "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
|
||||
3 "y" operand "x" operand r> execute
|
||||
"s48_long_to_bignum" f %alien-invoke
|
||||
! An untagged pointer to the bignum is now in r3; tag it
|
||||
3 "r" operand bignum-tag ORI
|
||||
"end" get save-xt ; inline
|
||||
"end" get resolve-label ; inline
|
||||
|
||||
\ fixnum+ [
|
||||
finalize-contents
|
||||
|
|
@ -164,7 +164,7 @@ math-internals namespaces sequences words ;
|
|||
|
||||
\ fixnum* [
|
||||
finalize-contents
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
"r" operand "x" operand untag-fixnum
|
||||
0 MTXER
|
||||
12 "y" operand "r" operand MULLWO.
|
||||
|
|
@ -178,7 +178,7 @@ math-internals namespaces sequences words ;
|
|||
"s48_bignum_arithmetic_shift" f %alien-invoke
|
||||
! An untagged pointer to the bignum is now in r3; tag it
|
||||
3 12 bignum-tag ORI
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
"s" operand 12 MR
|
||||
] H{
|
||||
{ +input { { f "x" } { f "y" } } }
|
||||
|
|
@ -192,8 +192,8 @@ math-internals namespaces sequences words ;
|
|||
#! through to the end, and the result is in "x" operand.
|
||||
#! Otherwise it jumps to the "no-overflow" label and the
|
||||
#! result is in "r" operand.
|
||||
<label> "end" set
|
||||
<label> "no-overflow" set
|
||||
"end" define-label
|
||||
"no-overflow" define-label
|
||||
"r" operand "x" operand "y" operand DIVW
|
||||
! if the result is greater than the most positive fixnum,
|
||||
! which can only ever happen if we do
|
||||
|
|
@ -209,9 +209,9 @@ math-internals namespaces sequences words ;
|
|||
finalize-contents
|
||||
generate-fixnum/i
|
||||
"end" get B
|
||||
"no-overflow" get save-xt
|
||||
"no-overflow" get resolve-label
|
||||
"r" operand "x" operand tag-fixnum
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
] H{
|
||||
{ +input { { f "x" } { f "y" } } }
|
||||
{ +scratch { { f "r" } { f "s" } } }
|
||||
|
|
@ -224,10 +224,10 @@ math-internals namespaces sequences words ;
|
|||
generate-fixnum/i
|
||||
0 "s" operand LI
|
||||
"end" get B
|
||||
"no-overflow" get save-xt
|
||||
"no-overflow" get resolve-label
|
||||
generate-fixnum-mod
|
||||
"r" operand "x" operand tag-fixnum
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
] H{
|
||||
{ +input { { f "x" } { f "y" } } }
|
||||
{ +scratch { { f "r" } { f "s" } } }
|
||||
|
|
@ -276,8 +276,8 @@ math-internals namespaces sequences words ;
|
|||
} define-intrinsic
|
||||
|
||||
\ type [
|
||||
<label> "f" set
|
||||
<label> "end" set
|
||||
"f" define-label
|
||||
"end" define-label
|
||||
! Get the tag
|
||||
"obj" operand "y" operand tag-mask ANDI
|
||||
! Tag the tag
|
||||
|
|
@ -294,10 +294,10 @@ math-internals namespaces sequences words ;
|
|||
"x" operand "obj" operand object-tag neg LWZ
|
||||
"x" operand dup untag
|
||||
"end" get B
|
||||
"f" get save-xt
|
||||
"f" get resolve-label
|
||||
! The pointer is equal to 3. Load F_TYPE (9).
|
||||
f type tag-bits shift "x" operand LI
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
] H{
|
||||
{ +input { { f "obj" } } }
|
||||
{ +scratch { { f "x" } { f "y" } } }
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ M: object load-literal ( literal vreg -- )
|
|||
#! 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
|
||||
"end" define-label
|
||||
! Untag and multiply to get a jump table offset
|
||||
"n" operand fixnum>slot@
|
||||
! Add to jump table base. We use a temporary register since
|
||||
|
|
@ -124,7 +124,7 @@ M: object load-literal ( literal vreg -- )
|
|||
! Align for better performance
|
||||
compile-aligned
|
||||
! Fix up jump table pointer
|
||||
"end" get save-xt ;
|
||||
"end" get resolve-label ;
|
||||
|
||||
: %return ( -- ) %epilogue RET ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,9 +15,9 @@ IN: compiler
|
|||
|
||||
\ type [
|
||||
#! Intrinstic version of type primitive.
|
||||
<label> "header" set
|
||||
<label> "f" set
|
||||
<label> "end" set
|
||||
"header" define-label
|
||||
"f" define-label
|
||||
"end" define-label
|
||||
! Make a copy
|
||||
"x" operand "obj" operand MOV
|
||||
! Get the tag
|
||||
|
|
@ -29,7 +29,7 @@ IN: compiler
|
|||
! It doesn't store type info in its header
|
||||
"obj" operand tag-bits SHL
|
||||
"end" get JMP
|
||||
"header" get save-xt
|
||||
"header" get resolve-label
|
||||
! It does store type info in its header
|
||||
! Is the pointer itself equal to 3? Then its F_TYPE (9).
|
||||
"x" operand object-tag CMP
|
||||
|
|
@ -39,10 +39,10 @@ IN: compiler
|
|||
! Mask off header tag, making a fixnum.
|
||||
"obj" operand object-tag XOR
|
||||
"end" get JMP
|
||||
"f" get save-xt
|
||||
"f" get resolve-label
|
||||
! The pointer is equal to 3. Load F_TYPE (9).
|
||||
"obj" operand f type tag-bits shift MOV
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
] H{
|
||||
{ +input { { f "obj" } } }
|
||||
{ +scratch { { f "x" } { f "y" } } }
|
||||
|
|
@ -166,7 +166,7 @@ IN: compiler
|
|||
"z" operand "y" operand pick execute
|
||||
! If the previous arithmetic operation overflowed, then we
|
||||
! turn the result into a bignum and leave it in EAX.
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
"end" get JNO
|
||||
! There was an overflow. Recompute the original operand.
|
||||
{ "y" "x" } [ tag-bits SAR ] unique-operands
|
||||
|
|
@ -175,7 +175,7 @@ IN: compiler
|
|||
! An untagged pointer to the bignum is now in EAX; tag it
|
||||
T{ int-regs } return-reg bignum-tag OR
|
||||
"z" operand T{ int-regs } return-reg ?MOV
|
||||
"end" get save-xt ; inline
|
||||
"end" get resolve-label ; inline
|
||||
|
||||
: simple-overflow-template ( word insn -- )
|
||||
[ simple-overflow ] curry H{
|
||||
|
|
@ -192,7 +192,7 @@ IN: compiler
|
|||
finalize-contents
|
||||
"y" operand tag-bits SAR
|
||||
"y" operand IMUL
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
"end" get JNO
|
||||
"s48_fixnum_pair_to_bignum" f
|
||||
"x" operand remainder-reg 2array compile-c-call*
|
||||
|
|
@ -202,7 +202,7 @@ IN: compiler
|
|||
"x" operand tag-bits neg 2array compile-c-call*
|
||||
! an untagged pointer to the bignum is now in EAX; tag it
|
||||
T{ int-regs } return-reg bignum-tag OR
|
||||
"end" get save-xt
|
||||
"end" get resolve-label
|
||||
] H{
|
||||
{ +input { { 0 "x" } { 1 "y" } } }
|
||||
{ +output { "x" } }
|
||||
|
|
@ -212,7 +212,7 @@ IN: compiler
|
|||
#! The same code is used for fixnum/i and fixnum/mod.
|
||||
#! This has specific register
|
||||
#! ECX and EAX, and the result is in EDX.
|
||||
<label> "end" set
|
||||
"end" define-label
|
||||
prepare-division
|
||||
"y" operand IDIV
|
||||
! Make a copy since following shift is destructive
|
||||
|
|
@ -235,7 +235,7 @@ IN: compiler
|
|||
stack-reg 16 cell - ADD
|
||||
! the remainder is now in EDX
|
||||
remainder-reg POP
|
||||
"end" get save-xt ;
|
||||
"end" get resolve-label ;
|
||||
|
||||
\ fixnum/i [ generate-fixnum/mod ] H{
|
||||
{ +input { { 0 "x" } { 1 "y" } } }
|
||||
|
|
|
|||
18
vm/alien.c
18
vm/alien.c
|
|
@ -46,13 +46,6 @@ void *unbox_alien(void)
|
|||
return alien_offset(dpop());
|
||||
}
|
||||
|
||||
/* pop ( alien n ) from datastack, return alien's address plus n */
|
||||
INLINE void *alien_pointer(void)
|
||||
{
|
||||
F_FIXNUM offset = unbox_signed_cell();
|
||||
return unbox_alien() + offset;
|
||||
}
|
||||
|
||||
/* make an alien */
|
||||
ALIEN *make_alien(CELL delegate, CELL displacement)
|
||||
{
|
||||
|
|
@ -98,7 +91,14 @@ void fixup_alien(ALIEN *d)
|
|||
d->expired = true;
|
||||
}
|
||||
|
||||
/* define words to read/write numericals values at an alien address */
|
||||
/* pop ( alien n ) from datastack, return alien's address plus n */
|
||||
INLINE void *alien_pointer(void)
|
||||
{
|
||||
F_FIXNUM offset = unbox_signed_cell();
|
||||
return unbox_alien() + offset;
|
||||
}
|
||||
|
||||
/* define words to read/write values at an alien address */
|
||||
#define DEF_ALIEN_SLOT(name,type,boxer) \
|
||||
void primitive_alien_##name (void) \
|
||||
{ \
|
||||
|
|
@ -139,7 +139,7 @@ void box_value_struct(void *src, CELL size)
|
|||
}
|
||||
|
||||
/* for FFI calls returning an 8-byte struct. This only
|
||||
happends on Intel Mac OS X */
|
||||
happens on Intel Mac OS X */
|
||||
void box_value_pair(CELL x, CELL y)
|
||||
{
|
||||
F_ARRAY *array = byte_array(8);
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@ MIT in each case. */
|
|||
*/
|
||||
|
||||
/* Changes for Factor:
|
||||
* - Add s48_ prefix to file names
|
||||
* - Adapt s48_bignumint.h for Factor memory manager
|
||||
* - Add more bignum <-> C type conversions
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -22,7 +22,6 @@ void init_factor(const char* image,
|
|||
userenv[CARD_OFF_ENV] = tag_cell(cards_offset);
|
||||
userenv[IMAGE_ENV] = tag_object(from_char_string(image));
|
||||
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
|
||||
userenv[COMPILED_BASE_ENV] = tag_cell(compiling.base);
|
||||
}
|
||||
|
||||
INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
|
||||
|
|
|
|||
24
vm/image.c
24
vm/image.c
|
|
@ -179,6 +179,9 @@ void undefined_symbol(void)
|
|||
|
||||
INLINE CELL get_literal(CELL literal_start, CELL num)
|
||||
{
|
||||
if(!literal_start)
|
||||
critical_error("Only RT_LABEL relocations can appear in the label-relocation-table",0);
|
||||
|
||||
return get(LITERAL_REF(literal_start,num));
|
||||
}
|
||||
|
||||
|
|
@ -209,9 +212,13 @@ CELL get_rel_word(F_REL *rel, CELL literal_start)
|
|||
return (CELL)word->xt;
|
||||
}
|
||||
|
||||
INLINE CELL compute_code_rel(F_REL *rel, CELL original,
|
||||
CELL offset, CELL literal_start)
|
||||
INLINE CELL compute_code_rel(F_REL *rel,
|
||||
CELL code_start, CELL literal_start,
|
||||
F_VECTOR *labels)
|
||||
{
|
||||
CELL offset = rel->offset + code_start;
|
||||
F_ARRAY *array = untag_array_fast(labels->array);
|
||||
|
||||
switch(REL_TYPE(rel))
|
||||
{
|
||||
case RT_PRIMITIVE:
|
||||
|
|
@ -226,13 +233,20 @@ INLINE CELL compute_code_rel(F_REL *rel, CELL original,
|
|||
return LITERAL_REF(literal_start,REL_ARGUMENT(rel));
|
||||
case RT_WORD:
|
||||
return get_rel_word(rel,literal_start);
|
||||
case RT_LABEL:
|
||||
if(labels == NULL)
|
||||
critical_error("RT_LABEL can only appear in label-relocation-table",0);
|
||||
|
||||
return to_fixnum(get(AREF(array,REL_ARGUMENT(rel))))
|
||||
+ code_start;
|
||||
default:
|
||||
critical_error("Unsupported rel type",rel->type);
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
|
||||
void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
|
||||
F_VECTOR *labels)
|
||||
{
|
||||
CELL original;
|
||||
CELL new_value;
|
||||
|
|
@ -270,7 +284,7 @@ INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
|
|||
|
||||
/* to_c_string can fill up the heap */
|
||||
maybe_gc(0);
|
||||
new_value = compute_code_rel(rel,original,offset,literal_start);
|
||||
new_value = compute_code_rel(rel,code_start,literal_start,labels);
|
||||
|
||||
switch(REL_CLASS(rel))
|
||||
{
|
||||
|
|
@ -321,7 +335,7 @@ CELL relocate_code_next(CELL relocating)
|
|||
|
||||
/* apply relocations */
|
||||
while(rel < rel_end)
|
||||
relocate_code_step(rel++,code_start,literal_start);
|
||||
relocate_code_step(rel++,code_start,literal_start,NULL);
|
||||
|
||||
CELL *scan = (CELL*)literal_start;
|
||||
CELL *literal_end = (CELL*)(literal_start + compiled->literal_length);
|
||||
|
|
|
|||
|
|
@ -53,7 +53,9 @@ typedef enum {
|
|||
/* an indirect literal from the word's literal table */
|
||||
RT_LITERAL,
|
||||
/* a word */
|
||||
RT_WORD
|
||||
RT_WORD,
|
||||
/* a local label */
|
||||
RT_LABEL
|
||||
} F_RELTYPE;
|
||||
|
||||
#define REL_ABSOLUTE_CELL 0
|
||||
|
|
@ -88,6 +90,8 @@ INLINE void code_fixup(CELL *cell)
|
|||
|
||||
void relocate_data();
|
||||
|
||||
void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
|
||||
F_VECTOR *labels);
|
||||
CELL relocate_code_next(CELL relocating);
|
||||
void relocate_code();
|
||||
|
||||
|
|
|
|||
41
vm/run.c
41
vm/run.c
|
|
@ -319,19 +319,35 @@ void deposit_vector(F_VECTOR *vector, CELL format)
|
|||
compiling.here += count * format;
|
||||
}
|
||||
|
||||
void add_compiled_block(F_VECTOR *code, CELL code_format,
|
||||
F_VECTOR *reloc, F_VECTOR *literals)
|
||||
void fixup_labels(F_VECTOR *label_rel, CELL code_start, CELL literal_start,
|
||||
F_VECTOR *labels)
|
||||
{
|
||||
F_ARRAY *array = untag_array_fast(labels->array);
|
||||
CELL length = untag_fixnum_fast(label_rel->top);
|
||||
CELL i;
|
||||
|
||||
for(i = 0; i < length; i += 2)
|
||||
{
|
||||
F_REL rel;
|
||||
rel.type = to_cell(get(AREF(array,i)));
|
||||
rel.offset = to_cell(get(AREF(array,i + 1)));
|
||||
relocate_code_step(&rel,code_start,literal_start,labels);
|
||||
}
|
||||
}
|
||||
|
||||
void add_compiled_block(CELL code_format, F_VECTOR *code, F_VECTOR *label_rel,
|
||||
F_VECTOR *labels, F_VECTOR *literals, F_VECTOR *rel)
|
||||
{
|
||||
CELL start = compiling.here;
|
||||
CELL code_length = untag_fixnum_fast(code->top) * code_format;
|
||||
CELL reloc_length = untag_fixnum_fast(reloc->top) * CELLS;
|
||||
CELL rel_length = untag_fixnum_fast(rel->top) * CELLS;
|
||||
CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
|
||||
|
||||
/* compiled header */
|
||||
F_COMPILED header;
|
||||
header.header = COMPILED_HEADER;
|
||||
header.code_length = align8(code_length);
|
||||
header.reloc_length = reloc_length;
|
||||
header.reloc_length = rel_length;
|
||||
header.literal_length = literal_length;
|
||||
memcpy((void*)compiling.here,&header,sizeof(F_COMPILED));
|
||||
compiling.here += sizeof(F_COMPILED);
|
||||
|
|
@ -340,24 +356,29 @@ void add_compiled_block(F_VECTOR *code, CELL code_format,
|
|||
deposit_vector(code,code_format);
|
||||
compiling.here = align8(compiling.here);
|
||||
|
||||
/* relocation info */
|
||||
deposit_vector(reloc,CELLS);
|
||||
/* relation info */
|
||||
deposit_vector(rel,CELLS);
|
||||
|
||||
/* literals */
|
||||
deposit_vector(literals,CELLS);
|
||||
|
||||
/* labels */
|
||||
fixup_labels(label_rel,start + sizeof(F_COMPILED),0,labels);
|
||||
|
||||
/* push the XT of the new word on the stack */
|
||||
box_unsigned_cell(start + sizeof(F_COMPILED));
|
||||
}
|
||||
|
||||
void primitive_add_compiled_block(void)
|
||||
{
|
||||
F_VECTOR *literals = untag_vector(dpop());
|
||||
F_VECTOR *rel = untag_vector(dpop());
|
||||
CELL code_format = to_cell(dpop());
|
||||
F_VECTOR *code = untag_vector(dpop());
|
||||
|
||||
add_compiled_block(code,code_format,rel,literals);
|
||||
F_VECTOR *label_rel = untag_vector(dpop());
|
||||
F_VECTOR *labels = untag_vector(dpop());
|
||||
F_VECTOR *literals = untag_vector(dpop());
|
||||
F_VECTOR *rel = untag_vector(dpop());
|
||||
|
||||
add_compiled_block(code_format,code,label_rel,labels,literals,rel);
|
||||
}
|
||||
|
||||
void primitive_finalize_compile(void)
|
||||
|
|
|
|||
1
vm/run.h
1
vm/run.h
|
|
@ -29,7 +29,6 @@ CELL callframe_end;
|
|||
#define GEN_ENV 15 /* set to gen_count */
|
||||
#define IMAGE_ENV 16 /* image name */
|
||||
#define CELL_SIZE_ENV 17 /* sizeof(CELL) */
|
||||
#define COMPILED_BASE_ENV 18 /* base of code heap */
|
||||
|
||||
/* TAGGED user environment data; see getenv/setenv prims */
|
||||
DLLEXPORT CELL userenv[USER_ENV];
|
||||
|
|
|
|||
Loading…
Reference in New Issue