annotate keiko/keiko.iset @ 1:b5139af1a420 tip basis

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