comparison keiko/keiko.iset @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 #
2 # keiko.iset
3 #
4 # This file is part of the Oxford Oberon-2 compiler
5 # Copyright (c) 2006--2016 J. M. Spivey
6 # All rights reserved
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # 1. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # 2. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # 3. The name of the author may not be used to endorse or promote products
17 # derived from this software without specific prior written permission.
18 #
19 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
20 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
21 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
22 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
24 # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
25 # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
27 # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
28 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 #
30
31 defs {
32 #define local(n) ((uchar *) bp + (n))
33 #define parent(a, t) indir(pointer(bp[SL]) + a, t)
34 #define indir(p, t) (* (t *) (p))
35 #define subs(p, n, t) ((t *) (p))[n]
36 #define const(n) cp[CP_CONST+n]
37 #define jump(lab) pc = pc0 + lab
38 }
39
40
41 # CONSTANTS
42
43 inst PUSH {[-1,6,1] 1 2} V.i {$a}
44 inst LDKW {1 2} V.i {const($a).i}
45 inst LDKF {1 2} V.f {const($a).f}
46
47
48 # ADDRESSING OPERATORS
49
50 # Push address of local
51 # LOCAL n :: --> bp+n
52 inst LOCAL {1 2} V.x {local($a)}
53
54 # Compute indexed address
55 # INDEXs :: a, b --> a + s * b
56 inst OFFSET 0 B.x {pointer($1) + $2.i}
57 inst INDEXS 0 B.x {pointer($1) + ($2.i<<1)}
58 inst INDEXW 0 B.x {pointer($1) + ($2.i<<2)}
59 inst INDEXD 0 B.x {pointer($1) + ($2.i<<3)}
60
61
62 # LOADS AND STORES
63
64 # Load/store from address
65 # LOADs :: a --> mem_s[a]
66 # STOREs :: a, b --> []; mem_s[b] := a
67 inst LOADW 0 M.i {indir(pointer($1), int)}
68 inst LOADS 0 M.i {indir(pointer($1), short)}
69 inst LOADC 0 M.i {indir(pointer($1), uchar)}
70 inst LOADF 0 M.f {indir(pointer($1), float)}
71 inst STOREW 0 S2 {indir(pointer($2), int) = $1.i;}
72 inst STORES 0 S2 {indir(pointer($2), short) = $1.i;}
73 inst STOREC 0 S2 {indir(pointer($2), uchar) = $1.i;}
74 inst STOREF 0 S2 {indir(pointer($2), float) = $1.f;}
75
76 # Load/store local
77 # LDLs n :: --> mem_s[bp+n]
78 # STLs n :: a --> []; mem_s[bp+n] := a
79 inst LDLW {[-24,-4,4] [12,32,4] 1 2} \
80 V.i {indir(local($a), int)}
81 inst LDLS {1 2} V.i {indir(local($a), short)}
82 inst LDLC {1 2} V.i {indir(local($a), uchar)}
83 inst LDLF {1 2} V.f {indir(local($a), float)}
84 inst STLW {[-24,-4,4] [12,32,4] 1 2} \
85 S1 {indir(local($a), int) = $1.i;}
86 inst STLS {1 2} S1 {indir(local($a), short) = $1.i;}
87 inst STLC {1 2} S1 {indir(local($a), uchar) = $1.i;}
88 inst STLF {1 2} S1 {indir(local($a), float) = $1.f;}
89
90 # Load/store global
91 # LDGs n :: --> mem_s[const(n)]
92 # STGs n :: a --> []; mem_s[const(n)] := a
93 inst LDGW {K L} V.i {indir(pointer(const($a)), int)}
94 inst LDGS {K L} V.i {indir(pointer(const($a)), short)}
95 inst LDGC {K L} V.i {indir(pointer(const($a)), uchar)}
96 inst LDGF {K L} V.f {indir(pointer(const($a)), float)}
97 inst STGW {K L} S1 {indir(pointer(const($a)), int) = $1.i;}
98 inst STGS {K L} S1 {indir(pointer(const($a)), short) = $1.i;}
99 inst STGC {K L} S1 {indir(pointer(const($a)), uchar) = $1.i;}
100 inst STGF {K L} S1 {indir(pointer(const($a)), float) = $1.f;}
101
102 # Indexed load/store
103 # LDNs n :: a -> mem_s[a+n]
104 # STNs n :: a, b -> []; mem_s[b+n] := a
105 inst LDNW {[-16,40,4] 1 2} M.i {indir(pointer($1) + $a, int)}
106 inst STNW {[-16,20,4] 1 2} S2 {indir(pointer($2) + $a, int) = $1.i;}
107
108 # Double indexed load/store
109 # LDIs :: a, b --> mem_s[a+s*b]
110 # STIs :: a, b, c --> []; mem_s[b+s*c] := a
111 inst LDIW 0 B.i {subs(pointer($1), $2.i, int)}
112 inst LDIF 0 B.f {subs(pointer($1), $2.i, float)}
113 inst LDIS 0 B.i {subs(pointer($1), $2.i, short)}
114 inst LDIC 0 B.i {subs(pointer($1), $2.i, uchar)}
115 inst STIW 0 S3 {subs(pointer($2), $3.i, int) = $1.i;}
116 inst STIF 0 S3 {subs(pointer($2), $3.i, float) = $1.f;}
117 inst STIS 0 S3 {subs(pointer($2), $3.i, short) = $1.i;}
118 inst STIC 0 S3 {subs(pointer($2), $3.i, uchar) = $1.i;}
119
120 inst LDID 0 B.dpi \
121 {getdbl((value *) &subs(pointer($1), $2.i, double))}
122 inst STID 0 S3dpi \
123 {putdbl((value *) &subs(pointer($2), $3.i, double), $1.d);}
124
125 inst LDIQ 0 B.qpi \
126 {getlong((value *) &subs(pointer($1), $2.i, longint))}
127 inst STIQ 0 S3qpi \
128 {putlong((value *) &subs(pointer($2), $3.i, longint), $1.q);}
129
130 # If the argument of any of the above instructions is so large that it
131 # does not fit in two bytes, then it's the job of the compiler to find
132 # an equivalent sequence using LDKW that achieves the same effect:
133 # for example, LDLW n --> LDKW [n] / LOADW
134
135 # Loads and stores for doubles
136 inst LOADD 0 M.dp {getdbl(valptr($1))}
137 inst STORED 0 S2dp {putdbl(valptr($2), $1.d);}
138 inst LDKD {1 2} V.d {getdbl(&const($a))}
139
140 inst LOADQ 0 M.qp {getlong(valptr($1))}
141 inst STOREQ 0 S2qp {putlong(valptr($2), $1.q);}
142 inst LDKQ {1 2} V.q {getlong(&const($a))}
143
144 equiv LDLD 1 {LOCAL $a, LOADD}
145 equiv STLD 1 {LOCAL $a, STORED}
146 equiv LDGD K {LDKW $a, LOADD}
147 equiv STGD K {LDKW $a, STORED}
148
149 equiv LDLQ 1 {LOCAL $a, LOADQ}
150 equiv STLQ 1 {LOCAL $a, STOREQ}
151 equiv LDGQ K {LDKW $a, LOADQ}
152 equiv STGQ K {LDKW $a, STOREQ}
153
154 # ASSORTED INSTRUCTIONS
155
156 defs {
157 #define dup(n, sp) sp--; sp[0] = sp[n+1]
158 #define swap(sp) sp[-1] = sp[1]; sp[1] = sp[0]; sp[0] = sp[-1]
159 }
160 inst INCL 1 S0 {indir(local($a), int)++;}
161 inst DECL 1 S0 {indir(local($a), int)--;}
162 inst DUP {[0,2,1]} S0 {dup($a, $s);}
163 inst SWAP 0 S0 {swap($s);}
164 inst POP 1 S0 {sp += $a;}
165
166 equiv INCL 2 {LDLW $a, INC, STLW $a}
167 equiv DECL 2 {LDLW $a, DEC, STLW $a}
168
169
170 # INTEGER OPERATORS
171
172 defs {
173 #define ror(a, b) ((((unsigned) a) >> b) | (((unsigned) a) << (32-b)))
174 }
175 inst PLUS 0 B.i {$1.i + $2.i}
176 inst MINUS 0 B.i {$1.i - $2.i}
177 inst TIMES 0 B.i {$1.i * $2.i}
178 inst UMINUS 0 M.i {- $1.i}
179 inst AND 0 B.i {$1.i && $2.i}
180 inst OR 0 B.i {$1.i || $2.i}
181 inst NOT 0 M.i {! $1.i}
182 inst INC 0 M.i {$1.i + 1}
183 inst DEC 0 M.i {$1.i - 1}
184 inst BITAND 0 B.i {$1.i & $2.i}
185 inst BITOR 0 B.i {$1.i | $2.i}
186 inst BITXOR 0 B.i {$1.i ^ $2.i}
187 inst BITNOT 0 M.i {~ $1.i}
188 inst LSL 0 B.i {$1.i << $2.i}
189 inst LSR 0 B.i {((unsigned) $1.i) >> $2.i}
190 inst ASR 0 B.i {$1.i >> $2.i}
191 inst ROR 0 B.i {ror($1.i, $2.i)}
192
193 defs {
194 /* The DIV and MOD instructions must give the correct results, even if
195 C is wrong. Correct means that b * (a DIV b) + a MOD b = a, and
196 (-a) DIV (-b) = a DIV b, and if b > 0 then 0 <= a MOD b < b. */
197
198 static inline divop_decl(int)
199 static inline divop_decl(longint)
200 }
201
202 inst DIV 0 B.i {int_divop($1.i, $2.i, 1)}
203 inst MOD 0 B.i {int_divop($1.i, $2.i, 0)}
204
205 inst EQ 0 B.i {$1.i == $2.i}
206 inst LT 0 B.i {$1.i < $2.i}
207 inst GT 0 B.i {$1.i > $2.i}
208 inst LEQ 0 B.i {$1.i <= $2.i}
209 inst GEQ 0 B.i {$1.i >= $2.i}
210 inst NEQ 0 B.i {$1.i != $2.i}
211
212 inst JEQ {S R} S2 {if ($1.i == $2.i) jump($a);}
213 inst JLT {S R} S2 {if ($1.i < $2.i) jump($a);}
214 inst JGT {S R} S2 {if ($1.i > $2.i) jump($a);}
215 inst JLEQ {S R} S2 {if ($1.i <= $2.i) jump($a);}
216 inst JGEQ {S R} S2 {if ($1.i >= $2.i) jump($a);}
217 inst JNEQ {S R} S2 {if ($1.i != $2.i) jump($a);}
218
219 inst JLTZ S S1 {if ($1.i < 0) jump($a);}
220 inst JGTZ S S1 {if ($1.i > 0) jump($a);}
221 inst JLEQZ S S1 {if ($1.i <= 0) jump($a);}
222 inst JGEQZ S S1 {if ($1.i >= 0) jump($a);}
223
224 equiv JLTZ R {PUSH 0, JLT $a}
225 equiv JGTZ R {PUSH 0, JGT $a}
226 equiv JLEQZ R {PUSH 0, JLEQ $a}
227 equiv JGEQZ R {PUSH 0, JGEQ $a}
228
229 inst JNEQZ {S R} S1 {if ($1.i != 0) jump($a);}
230 inst JEQZ {S R} S1 {if ($1.i == 0) jump($a);}
231 inst JUMP {S R} S0 {jump($a);}
232
233 # LONGINT OPERATORS
234
235 inst QPLUS 0 B.q {$1.q + $2.q}
236 inst QMINUS 0 B.q {$1.q - $2.q}
237 inst QTIMES 0 B.q {$1.q * $2.q}
238 inst QUMINUS 0 M.q {- $1.q}
239 inst QDIV 0 B.q {longint_divop($1.q, $2.q, 1)}
240 inst QMOD 0 B.q {longint_divop($1.q, $2.q, 0)}
241
242 equiv QINC 0 {PUSH 1, CONVNQ, QPLUS}
243 equiv QDEC 0 {PUSH 1, CONVNQ, QMINUS}
244
245
246 # CASE STATEMENTS
247
248 defs {
249 #define jcase(x, n) \
250 if ((unsigned) x < (unsigned) n) { pc0 = pc + 2*x; jump(get2(pc0)); } \
251 else pc += 2*n
252 }
253 inst JCASE 1 S1 {jcase($1.i, $a);}
254 zinst CASEL R
255
256 inst JRANGE {S R} S3 {if ($1.i >= $2.i && $1.i <= $3.i) jump($a);}
257
258 # The "T2" means take two arguments, but leave one of them on the stack
259 inst TESTGEQ {S R} T2 {if ($1.i >= $2.i) jump($a);}
260
261
262 # FLOATING-POINT OPERATORS
263
264 inst FPLUS 0 B.f {$1.f + $2.f}
265 inst FMINUS 0 B.f {$1.f - $2.f}
266 inst FTIMES 0 B.f {$1.f * $2.f}
267 inst FDIV 0 B.f {$1.f / $2.f}
268 inst FUMINUS 0 M.f {- $1.f}
269
270 defs {
271 static inline int fcmpl(double a, double b) {
272 return (a > b ? 1 : a == b ? 0 : -1);
273 }
274
275 static inline int fcmpg(double a, double b) {
276 return (a < b ? -1 : a == b ? 0 : 1);
277 }
278
279 static inline int lcmp(longint a, longint b) {
280 return (a < b ? -1 : a > b ? 1 : 0);
281 }
282 }
283
284 inst FCMPL 0 B.i {fcmpl($1.f, $2.f)}
285 inst FCMPG 0 B.i {fcmpg($1.f, $2.f)}
286
287 equiv FEQ 0 {FCMPL, PUSH 0, EQ}
288 equiv FNEQ 0 {FCMPL, PUSH 0, NEQ}
289 equiv FLT 0 {FCMPG, PUSH 0, LT}
290 equiv FGT 0 {FCMPL, PUSH 0, GT}
291 equiv FLEQ 0 {FCMPG, PUSH 0, LEQ}
292 equiv FGEQ 0 {FCMPL, PUSH 0, GEQ}
293
294 # The floating-point conditional jumps are just shorthand for a
295 # comparison and an integer jump. This saves valuable opcodes for more
296 # important functions.
297 equiv FJEQ R {FCMPL, JEQZ $a}
298 equiv FJNEQ R {FCMPL, JNEQZ $a}
299 equiv FJLT R {FCMPG, JLTZ $a}
300 equiv FJGT R {FCMPL, JGTZ $a}
301 equiv FJLEQ R {FCMPG, JLEQZ $a}
302 equiv FJGEQ R {FCMPL, JGEQZ $a}
303 equiv FJNLT R {FCMPG, JGEQZ $a}
304 equiv FJNGT R {FCMPL, JLEQZ $a}
305 equiv FJNLEQ R {FCMPG, JGTZ $a}
306 equiv FJNGEQ R {FCMPL, JLTZ $a}
307
308 # DOUBLE-PRECISION OPERATORS
309
310 defs {
311 #ifdef UNALIGNED_MEM
312 #define getdbl get_double
313 #define putdbl put_double
314 #define getlong get_long
315 #define putlong put_long
316 #else
317 static inline double getdbl(value *v) {
318 dblbuf dd;
319 dd.n.lo = v[0].i;
320 dd.n.hi = v[1].i;
321 return dd.d;
322 }
323
324 static inline void putdbl(value *v, double x) {
325 dblbuf dd;
326 dd.d = x;
327 v[0].i = dd.n.lo;
328 v[1].i = dd.n.hi;
329 }
330
331 static inline longint getlong(value *v) {
332 dblbuf dd;
333 dd.n.lo = v[0].i;
334 dd.n.hi = v[1].i;
335 return dd.q;
336 }
337
338 static inline void putlong(value *v, longint x) {
339 dblbuf dd;
340 dd.q = x;
341 v[0].i = dd.n.lo;
342 v[1].i = dd.n.hi;
343 }
344 #endif
345 }
346
347 inst DPLUS 0 B.d {$1.d + $2.d}
348 inst DMINUS 0 B.d {$1.d - $2.d}
349 inst DTIMES 0 B.d {$1.d * $2.d}
350 inst DDIV 0 B.d {$1.d / $2.d}
351 inst DUMINUS 0 M.d {- $1.d}
352
353 inst DCMPL 0 B.idd {fcmpl($1.d, $2.d)}
354 inst DCMPG 0 B.idd {fcmpg($1.d, $2.d)}
355
356 equiv DEQ 0 {DCMPL, PUSH 0, EQ}
357 equiv DNEQ 0 {DCMPL, PUSH 0, NE}
358 equiv DLT 0 {DCMPG, PUSH 0, LT}
359 equiv DGT 0 {DCMPL, PUSH 0, GT}
360 equiv DLEQ 0 {DCMPG, PUSH 0, LE}
361 equiv DGEQ 0 {DCMPL, PUSH 0, GE}
362
363 equiv DJEQ R {DCMPL, JEQZ $a}
364 equiv DJNEQ R {DCMPL, JNEQZ $a}
365 equiv DJLT R {DCMPG, JLTZ $a}
366 equiv DJGT R {DCMPL, JGTZ $a}
367 equiv DJLEQ R {DCMPG, JLEQZ $a}
368 equiv DJGEQ R {DCMPL, JGEQZ $a}
369 equiv DJNLT R {DCMPG, JGEQZ $a}
370 equiv DJNGT R {DCMPL, JLEQZ $a}
371 equiv DJNLEQ R {DCMPG, JGTZ $a}
372 equiv DJNGEQ R {DCMPL, JLTZ $a}
373
374 inst QCMP 0 B.iqq {lcmp($1.q, $2.q)}
375
376 equiv QEQ 0 {QCMP, PUSH 0, EQ}
377 equiv QLT 0 {QCMP, PUSH 0, LT}
378 equiv QGT 0 {QCMP, PUSH 0, GT}
379 equiv QLEQ 0 {QCMP, PUSH 0, LEQ}
380 equiv QGEQ 0 {QCMP, PUSH 0, GEQ}
381 equiv QNEQ 0 {QCMP, PUSH 0, NEQ}
382
383 equiv QJEQ R {QCMP, JEQZ $a}
384 equiv QJLT R {QCMP, JLTZ $a}
385 equiv QJGT R {QCMP, JGTZ $a}
386 equiv QJLEQ R {QCMP, JLEQZ $a}
387 equiv QJGEQ R {QCMP, JGEQZ $a}
388 equiv QJNEQ R {QCMP, JNEQZ $a}
389
390
391 # CONVERSIONS
392
393 inst CONVNF 0 M.f {flo_conv($1.i)}
394 inst CONVND 0 M.di {flo_conv($1.i)}
395 inst CONVFN 0 M.i {(int) $1.f}
396 inst CONVDN 0 M.id {(int) $1.d}
397 inst CONVFD 0 M.df {$1.f}
398 inst CONVDF 0 M.fd {(float) $1.d}
399 inst CONVNC 0 M.i {$1.i & 0xff}
400 inst CONVNS 0 M.i {(short) $1.i}
401 inst CONVNQ 0 M.qi {$1.i}
402 inst CONVQN 0 M.iq {(int) $1.q}
403 inst CONVQD 0 M.dq {flo_convq($1.q)}
404
405
406 # RUN-TIME CHECKS
407
408 # The operand of these checks is the line number to show in the error
409 # message. God forbid people should make source files containing
410 # more than 65536 lines
411
412 defs {
413 static inline int boundcheck(unsigned i, unsigned n, int line,
414 value *bp, uchar *pc) {
415 if (i >= n) runtime_error(E_BOUND, line, bp, pc);
416 return i;
417 }
418
419 #define checkdef(name, type, arg, extra, test, msg) \
420 static inline type name(type arg extra, int line, \
421 value *bp, uchar *pc) { \
422 if (test) runtime_error(msg, line, bp, pc); \
423 return arg; \
424 }
425
426 checkdef(nullcheck, uchar *, p,, p == NULL, E_NULL)
427 checkdef(zerocheck, int, n,, n == 0, E_DIV)
428 checkdef(fzerocheck, double, x,, x == 0.0, E_FDIV)
429 checkdef(lzerocheck, longint, n,, n == 0, E_DIV)
430 checkdef(globcheck, value *, p,, p != NULL, E_GLOB)
431
432 #define czech(chk, a, n) chk(a, n, bp, pc0)
433 #define czech2(chk, a, b, n) chk(a, b, n, bp, pc0)
434 #define error(msg, n) runtime_error(msg, n, bp, pc0);
435 }
436
437 inst BOUND 2 B.i {czech2(boundcheck, $1.i, $2.i, $a)}
438 inst NCHECK 2 M.x {czech(nullcheck, pointer($1), $a)}
439 inst GCHECK 2 S1 {czech(globcheck, valptr($1), $a);}
440 inst ZCHECK 2 M.i {czech(zerocheck, $1.i, $a)}
441 inst FZCHECK 2 M.f {czech(fzerocheck, $1.f, $a)}
442 inst DZCHECK 2 M.d {czech(fzerocheck, $1.d, $a)}
443 inst QZCHECK 2 M.q {czech(lzerocheck, $1.q, $a)}
444 inst ERROR 12 S0 {error($a, $b);}
445 equiv EASSERT 2 {RESULTW, ERROR E_ASSERT $a}
446
447
448 # MORE BITS AND PIECES
449
450 # ALIGNs instructions are used on big-endian machines like the SPARC
451 # to ensure that CHAR and SHORT parameters appear at the right address.
452 defs {
453 #ifdef WORDS_BIGENDIAN
454 #define alignx(a, n) (a <<= (32-n))
455 #else
456 #define alignx(a, n) a
457 #endif
458 }
459 inst ALIGNC 0 M.i {alignx($1.i, 8)}
460 inst ALIGNS 0 M.i {alignx($1.i, 16)}
461
462 defs {
463 #ifdef PROFILE
464 #define prof_charge(n) ticks += n
465 #else
466 #define prof_charge(n)
467 #endif
468 }
469
470 # FIXCOPY copies a fixed number of bytes; it is used for structure
471 # assignment and also for value parameters of (fixed) array or record type. */
472 defs {
473 #define fixcopy(a, b, n) prof_charge(n/4); memcpy(a, b, n)
474 }
475 inst FIXCOPY 0 S3 {fixcopy(pointer($1), pointer($2), $3.i);}
476
477 # FLEXCOPY expects to find on the stack the address of a flex array parameter
478 # and a size in bytes; it copies the parameter to dynamic local space,
479 # then overwrites the parameter with the new address.
480 defs {
481 #define flexcopy(d0, size0) \
482 { value *d = (value *) d0; int size = size0; \
483 int sizew = (size+3)/4; prof_charge(sizew); \
484 sp -= sizew; \
485 if ((uchar *) sp < stack + SLIMIT) \
486 error(E_STACK, 0); \
487 memcpy(sp, pointer(d[0]), size); \
488 d[0].a = address(sp);}
489 }
490 inst FLEXCOPY 0 S2 {flexcopy(pointer($1), $2.i);}
491
492 # In the interpreter, the CALLW and CALLD instructions are implemented as
493 # two operations, an ordinary CALL followed by a SLIDE; the return address
494 # of the called routine points to the SLIDE instruction, which is
495 # responsible for copying the result.
496 equiv CALL 1 {JPROC, SLIDE $a}
497 equiv CALLW 1 {JPROC, SLIDEW $a}
498 equiv CALLQ 1 {JPROC, SLIDEQ $a}
499 equiv CALLF 1 {JPROC, SLIDEF $a}
500 equiv CALLD 1 {JPROC, SLIDED $a}
501
502 inst LINK 0 S1 {statlink = valptr($1);}
503 inst SAVELINK 0 S0 {bp[SL].a = address(statlink);}
504
505 defs {
506 #define frame() \
507 bp = sp; \
508 sp = (value *) ((uchar *) bp - cp[CP_FRAME].i); \
509 if ((uchar *) sp < stack + SLIMIT) error(E_STACK, 0); \
510 memset(sp, 0, cp[CP_FRAME].i);
511
512 #ifdef OBXDEB
513 #define cond_break() \
514 if (one_shot && *pc != K_LNUM_2 && *pc != K_BREAK_2) \
515 debug_break(cp, bp, pc, "stop")
516 #else
517 #define cond_break()
518 #endif
519 }
520
521 inst JPROC 0 S0 {
522 value *p = valptr(sp[0]);
523 sp -= HEAD-1; sp[BP].a = address(bp); sp[PC].a = address(pc);
524 if (! interpreted(p)) {
525 #ifdef PROFILE
526 /* Calling a native-code routine */
527 prof_enter(p, ticks, PROF_PRIM);
528 ticks = 0;
529 #endif
530 #ifdef OBXDEB
531 prim_bp = sp;
532 #endif
533 primcall(p, sp);
534 #ifdef OBXDEB
535 prim_bp = NULL;
536 #endif
537 } else {
538 #ifdef PROFILE
539 prof_enter(p, ticks, PROF_CALL);
540 #endif
541 cp = p; pc = pointer(cp[CP_CODE]);
542 do_find_proc;
543 frame();
544 }
545 }
546
547 defs {
548 #define slide(nargs) sp += HEAD + nargs; cond_break();
549 }
550
551 inst SLIDE 1 S0 {slide($a);}
552 inst SLIDEW 1 S0 {slide($a); sp--; sp[0].i = ob_res.i;}
553 inst SLIDED 1 S0 {slide($a); sp -= 2;
554 putdbl(&sp[0], getdbl(&ob_res));}
555 inst SLIDEF 1 S0 {slide($a); sp--; sp[0].f = ob_res.f;}
556 inst SLIDEQ 1 S0 {slide($a); sp -= 2;
557 putlong(&sp[0], getlong(&ob_res));}
558
559 equiv RETURNW 0 {RESULTW, RETURN}
560 equiv RETURNF 0 {RESULTF, RETURN}
561 equiv RETURND 0 {RESULTD, RETURN}
562 equiv RETURNQ 0 {RESULTQ, RETURN}
563
564 inst RESULTW 0 S1 {ob_res = $1;}
565 inst RESULTD 0 S1d {putdbl(&ob_res, $1.d);}
566 inst RESULTF 0 S1 {ob_res.f = $1.f;}
567 inst RESULTQ 0 S1q {putlong(&ob_res, $1.q);}
568
569 inst RETURN 0 S0 {
570 if (bp == base) {
571 level--;
572 #ifdef PROFILE
573 prof_exit(NULL, ticks);
574 #endif
575 return;
576 }
577
578 sp = bp; pc = pointer(sp[PC]); bp = valptr(sp[BP]); cp = valptr(bp[CP]);
579 do_find_proc;
580 #ifdef PROFILE
581 prof_exit(cp, ticks);
582 ticks = 0;
583 #endif
584 cond_break();
585 }
586
587 inst LNUM 2 S0 {
588 #ifdef PROFILE
589 if (lflag) {
590 static module m = NULL; /* Cache most recent module */
591 ticks--;
592 if (m == NULL || cp < (value *) m->m_addr
593 || cp >= (value *) (m->m_addr + m->m_length)) {
594 m = find_module(cp);
595 }
596 m->m_lcount[$a-1]++;
597 }
598 #endif
599 #ifdef OBXDEB
600 if (intflag)
601 debug_break(cp, bp, pc0, "interrupt");
602 else if (one_shot)
603 debug_break(cp, bp, pc0, "line");
604 #endif
605 }
606
607 inst BREAK 2 S0 {
608 #ifdef OBXDEB
609 debug_break(cp, bp, pc0, "break");
610 #endif
611 }
612
613 if {[info exists SPECIALS]} {
614
615 # SPECIALS FOR COMPILERS COURSE
616
617 defs {
618 #define casejump(x, n0) \
619 { \
620 int n = n0; \
621 pc0 = pc; pc += 4*n; \
622 while (n > 0) { \
623 if (x == get2(pc0)) { \
624 jump(get2(pc0+2)); \
625 break; \
626 } \
627 pc0 += 4; n--; \
628 } \
629 }
630 }
631
632 inst CASEJUMP 1 S1 {casejump($1.i, $a);}
633 zinst CASEARM 2R
634
635 inst PACK 0 B.i {pack(valptr($2), pointer($1))}
636 inst UNPACK 0 S0 {sp--; sp[0].a = address(getcode(sp[1].i));
637 sp[1].a = address(getenvt(sp[1].i));}
638 }
639
640 zinst REG 0
641 zinst ADDR 0
642 zinst STACKW 0
643 zinst STACKQ 0
644 zinst CON 0
645
646
647 # DIRECTIVES
648
649 dir CONST ?
650 dir FCONST ?
651 dir DCONST ?
652 dir QCONST ?
653 dir GLOBAL ?
654 dir LABEL ?
655 dir PROC ????
656 dir END 0
657 dir PRIMDEF ???
658 dir DEFINE ?
659 dir STRING ?
660 dir GLOVAR ??
661 dir WORD ?
662 dir MODULE ???
663 dir ENDHDR 0
664 dir IMPORT ??
665 dir STKMAP ?
666 dir LINE ?
667
668 if {[info exists SPECIALS]} {
669 dir PCALL ?
670 dir PCALLW ?
671 }
672
673
674 # EXPANSIONS USED BY THE JIT TRANSLATOR
675
676 expand LDLW 1 {LOCAL $a, LOADW}
677 expand LDLS 1 {LOCAL $a, LOADS}
678 expand LDLC 1 {LOCAL $a, LOADC}
679 expand LDLF 1 {LOCAL $a, LOADF}
680 expand LDLD 1 {LOCAL $a, LOADD}
681 expand STLW 1 {LOCAL $a, STOREW}
682 expand STLS 1 {LOCAL $a, STORES}
683 expand STLC 1 {LOCAL $a, STOREC}
684 expand STLF 1 {LOCAL $a, STOREF}
685 expand STLD 1 {LOCAL $a, STORED}
686
687 expand LDGW 1 {LDKW $a, LOADW}
688 expand LDGS 1 {LDKW $a, LOADS}
689 expand LDGC 1 {LDKW $a, LOADC}
690 expand LDGF 1 {LDKW $a, LOADF}
691 expand LDGD 1 {LDKW $a, LOADD}
692 expand STGW 1 {LDKW $a, STOREW}
693 expand STGS 1 {LDKW $a, STORES}
694 expand STGC 1 {LDKW $a, STOREC}
695 expand STGF 1 {LDKW $a, STOREF}
696 expand STGD 1 {LDKW $a, STORED}
697
698 expand LDNW 1 {PUSH $a, OFFSET, LOADW}
699 expand STNW 1 {PUSH $a, OFFSET, STOREW}
700
701 expand INC 0 {PUSH 1, PLUS}
702 expand DEC 0 {PUSH 1, MINUS}
703
704 expand INCL 1 {LDLW $a, INC, STLW $a}
705 expand DECL 1 {LDLW $a, DEC, STLW $a}
706
707 expand JEQZ S {PUSH 0, JEQ $a}
708 expand JLTZ S {PUSH 0, JLT $a}
709 expand JGTZ S {PUSH 0, JGT $a}
710 expand JLEQZ S {PUSH 0, JLEQ $a}
711 expand JGEQZ S {PUSH 0, JGEQ $a}
712 expand JNEQZ S {PUSH 0, JNEQ $a}
713
714 expand LDIQ 0 {INDEXD, LOADQ}
715 expand STIQ 0 {INDEXD, STOREQ}