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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
|
/*-----------------------------------------------------------------*-C-*---
* File: handc/runtime/vinsns.h
*
* Copyright (C)1997 Donovan Kolbly <d.kolbly@rscheme.org>
* as part of the RScheme project, licensed for free use.
* See <http://www.rscheme.org/> for the latest information.
*
* File version: 1.23
* File mod date: 1997.11.29 23:10:49
* System build: v0.7.2, 97.12.21
*
* Purpose: virtual machine instruction set
*------------------------------------------------------------------------*/
#ifndef _H_VINSNS
#define _H_VINSNS
#include <rscheme/api.h>
#include <rscheme/regs.h>
#include <rscheme/smemory.h>
#include <rscheme/profile.h>
#ifdef GNU_VINSNS
#include <rscheme/vinsns_g.h>
#else
/* Structuring things */
#define PROLOGUE(fn_name)
#define MONOTONE(name) static jump_addr name( void )
#define EPILOGUE(fn_name)
#define BEGIN_FWD(fn_name)
#define FWD_MONOTONE(name) static jump_addr name( void );
#define END_FWD(fn_name)
#define JUMP_TABLE2(fn_name) fn_name ## _tab
#define JUMP_TABLE(fn_name) JUMP_TABLE2(fn_name)
#define BEGIN_BACK(fn_name) static jump_addr JUMP_TABLE(fn_name) [] = {
#define BACK_MONOTONE(name) (jump_addr)name,
#define END_BACK(fn_name) (jump_addr)NULL };
/* The virtual machine instructions */
#define TAILCALL(nextfn) return (jump_addr)nextfn
#define BJUMP(num,label) STMT(if (rsprof_active) rsprof_mt_bjumps(); \
arg_count_reg = num; \
return (jump_addr)label;)
#if defined(PROFILE_MONOTONES)
#define JUMP(num,label) BJUMP(num,label)
#else
#if PROFILING_HOOKS
#define JUMP(num,label) STMT(if (rsprof_active) rsprof_mt_jumps(); \
arg_count_reg = num; \
return (jump_addr)label;)
#else
#define JUMP(num,label) return (jump_addr)((jump_addr)label)()
#endif
#endif
#define APPLY(num,expr) STMT(arg_count_reg = num; \
return apply(CHECK_FUNCTION(expr));)
#define APPLYF(num,expr) STMT(arg_count_reg = num; \
return apply(expr);)
#define APPLYG(num,expr) STMT(arg_count_reg = num; \
return applyg(expr);)
#define APPLY_TMPL(num,expr,t) STMT(arg_count_reg = num; \
return apply_tmpl(CHECK_FUNCTION(expr),t);)
#define RETURN(num) STMT(arg_count_reg = num; TAILCALL(half_restore());)
#define LABEL_TO_JUMP_ADDR(label) ((jump_addr)label)
#endif /* GNU_VINSNS */
#define RETURN0() STMT(REG0=FALSE_OBJ; RETURN(0);)
#define RETURN1() RETURN(1);
void quasi_interp_spin( jump_addr first_m );
CIH_DECL jump_addr apply( obj closure );
CIH_DECL jump_addr apply_tmpl( obj closure, obj tmplate );
CIH_DECL jump_addr half_restore( void );
jump_addr rs_gf_dispatch( obj gf );
jump_addr applyg( obj gf );
obj rs_gf_find_method( obj gf, obj rcvr );
/************************ Miscellaneous ************************/
#define LITERAL(k) gvec_read( literals_reg, SLOT((k)+3) )
#define CLOSURE(k) make_closure(envt_reg,LITERAL(k))
#define TLREF(k) tlv_value( LITERAL(k) )
#define TLSET(k,x) tlv_set_value( LITERAL(k), (x) )
_rs_volatile void failed_type_check( obj place, obj var, obj val, obj expect );
_rs_volatile void apply_error( obj a_non_function );
_rs_volatile void done_w_call_scheme( void );
/************************ Binding Environments ************************/
obj nth_enclosing_envt( unsigned n );
CIH_DECL obj enclosing_envt( obj envt );
/* one of USE_FUNCTION_ENVT or USE_EMPTY_ENVT *MUST* be used
* if the function expects to have an environment in it's <function>
* object, or is going to bind arguments onto the heap.
*
* THIS_FUNCTION() may be used only *BEFORE* the use of one of those
* vinsns in the entry monotone
*/
#define USE_FUNCTION_ENVT() envt_reg = gvec_ref(envt_reg,SLOT(1))
#define USE_EMPTY_ENVT() envt_reg = NIL_OBJ
#define THIS_FUNCTION() envt_reg
#define LEXREF(frame,i) (rs_profile2("lexref",frame,i),\
gvec_read(nth_enclosing_envt(frame),SLOT((i)+1)))
#ifdef RS_PROFILE
#define LEXREF0(i) LEXREF(0,i)
#define LEXREF1(i) LEXREF(1,i)
#define LEXREF2(i) LEXREF(2,i)
#define LEXREF3(i) LEXREF(3,i)
#else
#define LEXREF0(i) gvec_read(envt_reg,SLOT((i)+1))
#define LEXREF1(i) gvec_read(enclosing_envt(envt_reg),SLOT((i)+1))
#define LEXREF2(i) gvec_read(enclosing_envt(\
enclosing_envt(envt_reg)),SLOT((i)+1))
#define LEXREF3(i) gvec_read(enclosing_envt(\
enclosing_envt(\
enclosing_envt(envt_reg))),SLOT((i)+1))
#endif
#define LEXREF4(i) LEXREF(4,i)
#define LEXREF5(i) LEXREF(5,i)
#define LEXREF6(i) LEXREF(6,i)
#define LEXREF7(i) LEXREF(7,i)
#define LEXREF8(i) LEXREF(8,i)
#define LEXREF9(i) LEXREF(9,i)
#define LEXSET(frame,i,v) (rs_profile2("lexset",frame,i),\
gvec_write(nth_enclosing_envt(frame),SLOT((i)+1),v))
#ifdef RS_PROFILE
#define LEXSET0(i,v) LEXSET(0,i,v)
#define LEXSET1(i,v) LEXSET(1,i,v)
#define LEXSET2(i,v) LEXSET(2,i,v)
#define LEXSET3(i,v) LEXSET(3,i,v)
#else
#define LEXSET0(i,v) gvec_write(envt_reg,SLOT((i)+1),v)
#define LEXSET1(i,v) gvec_write(enclosing_envt(envt_reg),SLOT((i)+1),v)
#define LEXSET2(i,v) gvec_write(enclosing_envt(\
enclosing_envt(envt_reg)),\
SLOT((i)+1),\
v)
#define LEXSET3(i,v) gvec_write(enclosing_envt(\
enclosing_envt(\
enclosing_envt(envt_reg))),\
SLOT((i)+1),\
v)
#endif
#define LEXSET4(i,v) LEXSET(4,i,v)
#define LEXSET5(i,v) LEXSET(5,i,v)
#define LEXSET6(i,v) LEXSET(6,i,v)
#define LEXSET7(i,v) LEXSET(7,i,v)
#define LEXSET8(i,v) LEXSET(8,i,v)
#define LEXSET9(i,v) LEXSET(9,i,v)
#define POPENVT() envt_reg = enclosing_envt( envt_reg )
/*
Some of the code in ctcprims (ie, bind_regs())
depends on this definition of BEGIN_BIND_
because it fakes the use of BEGIN_BIND_
*/
#define BEGIN_BIND_(c) { obj new_envt = c; \
gvec_write_init( new_envt, SLOT(0), envt_reg );
#define BEGIN_BIND(num) BEGIN_BIND_(alloc(SLOT((num)+1),binding_envt_class))
#define BEGIN_BIND0() BEGIN_BIND_(alloc1(binding_envt_class))
#define BEGIN_BIND1() BEGIN_BIND_(alloc2(binding_envt_class))
#define BEGIN_BIND2() BEGIN_BIND_(alloc3(binding_envt_class))
#define BEGIN_BIND3() BEGIN_BIND_(alloc4(binding_envt_class))
#define BEGIN_BIND4() BEGIN_BIND_(alloc5(binding_envt_class))
#define BEGIN_BIND5() BEGIN_BIND_(alloc6(binding_envt_class))
#define BEGIN_BIND6() BEGIN_BIND_(alloc7(binding_envt_class))
#define BEGIN_BIND7() BEGIN_BIND_(alloc8(binding_envt_class))
#define BEGIN_BIND8() BEGIN_BIND_(alloc9(binding_envt_class))
#define BEGIN_BIND9() BEGIN_BIND(9)
#define BIND_ARG(i,e) gvec_write_init( new_envt, SLOT((i)+1), e )
#define END_BIND envt_reg = new_envt; }
#define BIND1(e1) envt_reg = make2( binding_envt_class, envt_reg, \
e1 )
#define BIND2(e1,e2) envt_reg = make3( binding_envt_class, envt_reg, \
e1, e2 )
#define BIND3(e1,e2,e3) envt_reg = make4( binding_envt_class, envt_reg, \
e1, e2, e3 )
/************************ Argument Checking ************************/
_rs_volatile void wrong_num_args( const char *fn, unsigned num_required );
_rs_volatile void wrong_num_args_range( const char *fn,
unsigned min_rqd,
unsigned max_accepted );
_rs_volatile void too_few_args( const char *fn, unsigned min_required );
#define COUNT_ARGS(num) STMT( if (arg_count_reg != (num)) \
wrong_num_args( FUNCTION, num ); )
#define COUNT_ARGS_AT_LEAST(num) STMT( if (arg_count_reg < (num)) \
too_few_args( FUNCTION, num ); )
_rs_volatile void type_check_failed( const char *fn );
#define assert_type(expr) STMT( if (!(expr)) type_check_failed(FUNCTION); )
void pad_with_false( unsigned limit_reg );
unsigned expand_last( void );
obj collect_top( unsigned first_reg );
void collectn( unsigned first_reg ); /* reg(n) = collect_top(n); */
#define COLLECT_TOP() (arg_count_reg > 10)?collect_top(10):NIL_OBJ
#include <rscheme/collectn.h>
#define COLLECT(num) collectn(num)
#define PAD_WITH_FALSE0() /* nothing */
#define PAD_WITH_FALSE1() STMT( if (arg_count_reg == 0) REG0 = FALSE_OBJ; )
#define PAD_WITH_FALSE2() STMT( switch (arg_count_reg) { \
case 0: REG0 = FALSE_OBJ; \
case 1: REG1 = FALSE_OBJ; })
#define PAD_WITH_FALSE3() STMT( switch (arg_count_reg) { \
case 0: REG0 = FALSE_OBJ; \
case 1: REG1 = FALSE_OBJ; \
case 2: REG2 = FALSE_OBJ; })
#define PAD_WITH_FALSE4() STMT( switch (arg_count_reg) { \
case 0: REG0 = FALSE_OBJ; \
case 1: REG1 = FALSE_OBJ; \
case 2: REG2 = FALSE_OBJ; \
case 3: REG3 = FALSE_OBJ; })
#define PAD_WITH_FALSE(num) STMT(if (arg_count_reg < num) pad_with_false(num);)
/************************ Continuations ************************/
#define CONT_FIXED (4)
void save_cont( unsigned num, jump_addr label );
void restore_cont( unsigned num );
#ifdef STACK_CACHE
#include <rscheme/stakcach.h>
#else
#include <rscheme/stack.h>
#endif
#define PUSH_PARTCONT(label,space) PUSH_PARTCONT_ADDR(\
LABEL_TO_JUMP_ADDR(label),space)
#define SAVE_CONT0(label) push_cont(LABEL_TO_JUMP_ADDR(label),0)
#define SAVE_CONT1(label) STMT( PUSH_PARTCONT(label,1); \
SET_PARTCONT_REG(0,REG0); )
#define SAVE_CONT2(label) STMT( PUSH_PARTCONT(label,2); \
SET_PARTCONT_REG(0,REG0); \
SET_PARTCONT_REG(1,REG1); )
#define SAVE_CONT3(label) STMT( PUSH_PARTCONT(label,3); \
SET_PARTCONT_REG(0,REG0); \
SET_PARTCONT_REG(1,REG1); \
SET_PARTCONT_REG(2,REG2); )
#define SAVE_CONT4(label) STMT( PUSH_PARTCONT(label,4); \
SET_PARTCONT_REG(0,REG0); \
SET_PARTCONT_REG(1,REG1); \
SET_PARTCONT_REG(2,REG2); \
SET_PARTCONT_REG(3,REG3); )
#define SAVE_CONT5(label) save_cont(5,LABEL_TO_JUMP_ADDR(label))
#define SAVE_CONT6(label) save_cont(6,LABEL_TO_JUMP_ADDR(label))
#define SAVE_CONT7(label) save_cont(7,LABEL_TO_JUMP_ADDR(label))
#define SAVE_CONT8(label) save_cont(8,LABEL_TO_JUMP_ADDR(label))
#define SAVE_CONT9(label) save_cont(9,LABEL_TO_JUMP_ADDR(label))
#define SAVE_CONT(num,label) save_cont(num,LABEL_TO_JUMP_ADDR(label))
#define RESTORE_CONT_REG() continuation_reg = PARTCONT_REF(3)
#define PARTCONT_REG(i) PARTCONT_REF((i)+CONT_FIXED)
#define RESTORE_CONT0() RESTORE_CONT_REG()
#define RESTORE_CONT1() STMT( REG0 = PARTCONT_REG(0); RESTORE_CONT_REG(); )
#define RESTORE_CONT2() STMT( REG0 = PARTCONT_REG(0); \
REG1 = PARTCONT_REG(1); \
RESTORE_CONT_REG(); )
#define RESTORE_CONT3() STMT( REG0 = PARTCONT_REG(0); \
REG1 = PARTCONT_REG(1); \
REG2 = PARTCONT_REG(2); \
RESTORE_CONT_REG(); )
#define RESTORE_CONT4() STMT( REG0 = PARTCONT_REG(0); \
REG1 = PARTCONT_REG(1); \
REG2 = PARTCONT_REG(2); \
REG3 = PARTCONT_REG(3); \
RESTORE_CONT_REG(); )
#define RESTORE_CONT5() restore_cont(5)
#define RESTORE_CONT6() restore_cont(6)
#define RESTORE_CONT7() restore_cont(7)
#define RESTORE_CONT8() restore_cont(8)
#define RESTORE_CONT9() restore_cont(9)
#define RESTORE_CONT(num) restore_cont(num)
/***************************************************************/
#ifdef INLINES
#include <rscheme/vinsns.ci>
#endif /* INLINES */
/********* remapping C operators to function-looking things ****/
#define FLT_ADD(x,y) ((x)+(y))
#define FLT_SUB(x,y) ((x)-(y))
#define FLT_MUL(x,y) ((x)*(y))
#define FLT_DIV(x,y) ((x)/(y))
#define FLT_NEG(x) (-(x))
#define FLT_GT(x,y) ((x)>(y))
#define FLT_GE(x,y) ((x)>=(y))
#define FLT_LT(x,y) ((x)<(y))
#define FLT_LE(x,y) ((x)<=(y))
#define FLT_EQ(x,y) ((x)==(y))
#define FLT_TRUNC(x) ((int)(x))
#define FX_FLOAT(x) ((IEEE_64)(x))
/********* similar for register access ***/
#define GET_DYNAMIC_STATE_REG() dynamic_state_reg
#define SET_DYNAMIC_STATE_REG(v) (dynamic_state_reg = (v))
#define GET_THREAD_STATE_REG() thread_state_reg
#define SET_THREAD_STATE_REG(v) (thread_state_reg = (v))
#endif /* _H_VINSNS */
|
