4 F_CODE_BLOCK
*compile_profiling_stub(F_WORD
*word
)
6 CELL literals
= allot_array_1(tag_object(word
));
7 REGISTER_ROOT(literals
);
9 F_ARRAY
*quadruple
= untag_object(userenv
[JIT_PROFILING
]);
11 CELL code
= array_nth(quadruple
,0);
15 rel
.type
= to_fixnum(array_nth(quadruple
,2)) | (to_fixnum(array_nth(quadruple
,1)) << 8);
16 rel
.offset
= to_fixnum(array_nth(quadruple
,3)) * compiled_code_format();
18 F_BYTE_ARRAY
*relocation
= allot_byte_array(sizeof(F_REL
));
19 memcpy((void *)BREF(relocation
,0),&rel
,sizeof(F_REL
));
21 UNREGISTER_ROOT(code
);
22 UNREGISTER_ROOT(literals
);
24 return add_compiled_block(
28 tag_object(relocation
),
32 /* Allocates memory */
33 void update_word_xt(F_WORD
*word
)
39 REGISTER_UNTAGGED(word
);
40 F_CODE_BLOCK
*profiling
= compile_profiling_stub(word
);
41 UNREGISTER_UNTAGGED(word
);
42 word
->profiling
= profiling
;
45 word
->xt
= (XT
)(word
->profiling
+ 1);
48 word
->xt
= (XT
)(word
->code
+ 1);
51 void set_profiling(bool profiling
)
53 if(profiling
== profiling_p
)
56 profiling_p
= profiling
;
58 /* Push everything to tenured space so that we can heap scan
59 and allocate profiling blocks if necessary */
62 CELL words
= find_all_words();
67 CELL length
= array_capacity(untag_object(words
));
68 for(i
= 0; i
< length
; i
++)
70 F_WORD
*word
= untag_word(array_nth(untag_array(words
),i
));
72 word
->counter
= tag_fixnum(0);
76 UNREGISTER_ROOT(words
);
78 /* Update XTs in code heap */
79 iterate_code_heap(relocate_code_block
);
82 void primitive_profiling(void)
84 set_profiling(to_boolean(dpop()));