1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
/***********************************************************************/
/* */
/* Objective Caml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* $Id$ */
/* Primitives for the toplevel */
#include "alloc.h"
#include "config.h"
#include "fail.h"
#include "fix_code.h"
#include "interp.h"
#include "major_gc.h"
#include "memory.h"
#include "minor_gc.h"
#include "misc.h"
#include "mlvalues.h"
#include "prims.h"
#include "stacks.h"
#ifndef NATIVE_CODE
CAMLprim value get_global_data(value unit)
{
return global_data;
}
CAMLprim value reify_bytecode(value prog, value len)
{
value clos;
#ifdef ARCH_BIG_ENDIAN
fixup_endianness((code_t) prog, (asize_t) Long_val(len));
#endif
#ifdef THREADED_CODE
thread_code((code_t) prog, (asize_t) Long_val(len));
#endif
clos = alloc_small (1, Closure_tag);
Code_val(clos) = (code_t) prog;
return clos;
}
CAMLprim value realloc_global(value size)
{
mlsize_t requested_size, actual_size, i;
value new_global_data;
requested_size = Long_val(size);
actual_size = Wosize_val(global_data);
if (requested_size >= actual_size) {
requested_size = (requested_size + 0x100) & 0xFFFFFF00;
gc_message (0x08, "Growing global data to %lu entries\n", requested_size);
new_global_data = alloc_shr(requested_size, 0);
for (i = 0; i < actual_size; i++)
initialize(&Field(new_global_data, i), Field(global_data, i));
for (i = actual_size; i < requested_size; i++){
Field (new_global_data, i) = Val_long (0);
}
global_data = new_global_data;
}
return Val_unit;
}
CAMLprim value get_current_environment(value unit)
{
return *extern_sp;
}
CAMLprim value invoke_traced_function(value codeptr, value env, value arg)
{
/* Stack layout on entry:
return frame into instrument_closure function
arg3 to call_original_code (arg)
arg2 to call_original_code (env)
arg1 to call_original_code (codeptr)
arg3 to call_original_code (arg)
arg2 to call_original_code (env)
saved env */
/* Stack layout on exit:
return frame into instrument_closure function
actual arg to code (arg)
pseudo return frame into codeptr:
extra_args = 0
environment = env
PC = codeptr
arg3 to call_original_code (arg) same 6 bottom words as
arg2 to call_original_code (env) on entrance, but
arg1 to call_original_code (codeptr) shifted down 4 words
arg3 to call_original_code (arg)
arg2 to call_original_code (env)
saved env */
value * osp, * nsp;
int i;
osp = extern_sp;
extern_sp -= 4;
nsp = extern_sp;
for (i = 0; i < 6; i++) nsp[i] = osp[i];
nsp[6] = codeptr;
nsp[7] = env;
nsp[8] = Val_int(0);
nsp[9] = arg;
return Val_unit;
}
#else
/* Dummy definitions to support compilation of ocamlc.opt */
value get_global_data(value unit)
{
invalid_argument("Meta.get_global_data");
return Val_unit; /* not reached */
}
value realloc_global(value size)
{
invalid_argument("Meta.realloc_global");
return Val_unit; /* not reached */
}
value available_primitives(value unit)
{
invalid_argument("Meta.available_primitives");
return Val_unit; /* not reached */
}
value invoke_traced_function(value codeptr, value env, value arg)
{
invalid_argument("Meta.invoke_traced_function");
return Val_unit; /* not reached */
}
value * stack_low;
value * stack_high;
value * stack_threshold;
value * extern_sp;
value * trapsp;
int backtrace_active;
int backtrace_pos;
code_t * backtrace_buffer;
value backtrace_last_exn;
int callback_depth;
int volatile something_to_do;
void (* volatile async_action_hook)(void);
void print_exception_backtrace(void) { }
#endif
|
