Clean up functors so that the generated code looks sane with 'see'
[factor/jcg.git] / vm / profiler.c
blob66cefcf891f7bcd0c244f5b85cd998f2c60e15ce
1 #include "master.h"
3 /* Allocates memory */
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);
12 REGISTER_ROOT(code);
14 F_REL rel;
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(
25 WORD_TYPE,
26 untag_object(code),
27 NULL, /* no labels */
28 tag_object(relocation),
29 literals);
32 /* Allocates memory */
33 void update_word_xt(F_WORD *word)
35 if(profiling_p)
37 if(!word->profiling)
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);
47 else
48 word->xt = (XT)(word->code + 1);
51 void set_profiling(bool profiling)
53 if(profiling == profiling_p)
54 return;
56 profiling_p = profiling;
58 /* Push everything to tenured space so that we can heap scan
59 and allocate profiling blocks if necessary */
60 gc();
62 CELL words = find_all_words();
64 REGISTER_ROOT(words);
66 CELL i;
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));
71 if(profiling)
72 word->counter = tag_fixnum(0);
73 update_word_xt(word);
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()));