emu.l (48992B)
1 # 23jun13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Byte order 5 (in '("./sysdefs") 6 (case (read) 7 ("L" (on *LittleEndian)) 8 ("B" (off *LittleEndian)) 9 (T (quit "Bad endianess")) ) 10 (case (read) 11 (32 (off *Bits64)) 12 (64 (on *Bits64)) 13 (T (quit "Bad wordsize")) ) ) 14 15 (off *AlignedCode) 16 17 # Register assignments 18 (de *Registers 19 (A . "A") (C . "C") (E . "E") 20 (B . "A.b[0]") (D "A" . "C") 21 (X . "X") (Y . "Y") (Z . "Z") 22 (L . "L") (S . "S") 23 (F . T) ) 24 25 # Emulator specific 26 (off *AsmData *AsmCode *AsmOpcodes *Labels *SysFun) 27 (off *BaseData *BaseCode *BaseOpcodes) 28 (zero *AsmPos *OpOffs) 29 30 # Direct address expressions 31 (de directExpr (Str) 32 (let (Lst (str Str "_") A (_aggr)) 33 (or 34 (num? A) 35 (pack "(uint8_t*)" (text (cdr A) (car A))) ) ) ) 36 37 (de _aggr () 38 (let X (_prod) 39 (while (member (car Lst) '("+" "-")) 40 (let (Op (intern (pop 'Lst)) Y (_prod)) 41 (if2 (pair X) (pair Y) 42 (if (= '+ Op) 43 (quit "Bad direct expression") 44 (setq X (- (car X) (car Y))) ) 45 (set X (Op (car X) Y)) 46 (setq X (cons (Op X (car Y)))) 47 (and (sym? X) (or (baseCode X) (absCode X)) (setq X @)) 48 (and (sym? Y) (or (baseCode Y) (absCode Y)) (setq Y @)) 49 (setq X (Op X Y)) ) ) ) 50 X ) ) 51 52 (de _prod () 53 (let X (_term) 54 (while (member (car Lst) '("*" "/")) 55 (setq X ((intern (pop 'Lst)) X (_term))) ) 56 X ) ) 57 58 (de _term () 59 (let X (pop 'Lst) 60 (cond 61 ((num? X) X) 62 ((and *FPic (get *BaseData X)) 63 (cons @ "Data+@1") ) 64 ((get *AsmData X) 65 (cons (car @) (if *FPic "LibData+@1" "Data+@1")) ) 66 ((baseCode X) 67 (cons @ "(Code+@1)") ) 68 ((absCode X) 69 (cons @ (if *FPic "(LibCode+@1)" "(Code+@1)")) ) 70 ((= "+" X) (_term)) 71 ((= "-" X) (- (_term))) 72 ((= "(" X) (prog1 (_aggr) (pop 'Lst))) 73 (T (quit "Bad term" X)) ) ) ) 74 75 (de sysFun (S O) 76 (cond 77 ((=0 O) (pack "(void(*)())" S)) 78 ((absCode S) 79 (push1 '*SysFun 80 (pack 81 "void fun" 82 @ 83 "(long a, long c, long e, long x, long y, long z) {begin(" 84 @ 85 ", a, c, e, x, y, z);}" ) ) 86 (pack "(void(*)())fun" @) ) 87 (T (quit "Bad function address" S)) ) ) 88 89 # Addressing modes 90 (de op.p (Arg M) 91 (cond 92 ((=0 M) (pack "(uint8_t*)" Arg)) # Immediate 93 ((not M) (pack Arg ".p")) # Register 94 ((get Arg 'sys) @) 95 ((=T M) # Direct 96 (let E (directExpr Arg) 97 (if (num? E) 98 (pack "(uint8_t*)" E) 99 (pack "(" E ")") ) ) ) 100 ((get Arg 1 'sys) @) 101 ((=T (cdr M)) 102 (let E (directExpr (cdr Arg)) 103 (pack 104 "(*(ptr)(" 105 ((if (num? E) op.p op.n) (car Arg) (car M)) 106 " + " 107 E 108 ")).p" ) ) ) 109 ((cdr Arg) 110 (pack "(*(ptr)(" (op.p (car Arg) (car M)) " + " @ ")).p") ) 111 (T (pack "(*(ptr)" (op.p (car Arg) (car M)) ").p")) ) ) 112 113 (de op.n (Arg M) 114 (cond 115 ((=0 M) # Immediate 116 (let N (format Arg) 117 (if (>= N `(** 2 31)) 118 (pack "0x" (hex N) "LL") 119 Arg ) ) ) 120 ((not M) # Register 121 (if (= "A.b[0]" Arg) 122 Arg 123 (pack Arg ".n") ) ) 124 ((=T M) # Direct 125 (if (get Arg 'sys) 126 (pack "(uint64_t)(unsigned long)" (sysFun @ T)) 127 (let E (directExpr Arg) 128 (if (num? E) 129 (pack "(uint64_t)" E) 130 (pack "((uint64_t)(unsigned long)(" E "))") ) ) ) ) 131 ((=T (cdr M)) 132 (let E (directExpr (cdr Arg)) 133 (pack 134 "((ptr)(" 135 ((if (num? E) op.p op.n) (car Arg) (car M)) 136 " + " 137 E 138 "))->n" ) ) ) 139 ((cdr Arg) 140 (pack "((ptr)(" (op.p (car Arg) (car M)) " + " @ "))->n") ) 141 (T (pack "((ptr)" (op.p (car Arg) (car M)) ")->n")) ) ) 142 143 (de op.i (S O) 144 (if (and (format (setq S (op.n S O))) (>= 32767 (abs @))) 145 S 146 (pack "(int)" S) ) ) 147 148 (de op.b (Arg M) 149 (cond 150 ((=0 M) Arg) # Immediate 151 ((not M) # Register 152 (if (= "A.b[0]" Arg) 153 Arg 154 (pack Arg ".b[0]") ) ) 155 ((=T M) # Direct 156 (let E (directExpr Arg) 157 (if (num? E) 158 (pack "(uint8_t)" E) 159 (pack "*(" E ")") ) ) ) 160 ((=T (cdr M)) 161 (let E (directExpr (cdr Arg)) 162 (pack 163 "*(" 164 ((if (num? E) op.p op.n) (car Arg) (car M)) 165 " + " 166 E 167 ")" ) ) ) 168 ((cdr Arg) 169 (pack "*(" (op.p (car Arg) (car M)) " + " @ ")") ) 170 (T (pack "*" (op.p (car Arg) (car M)))) ) ) 171 172 (de op.a (Arg M) 173 (cond 174 ((=0 M) (quit "Can't take address" Arg)) # Immediate 175 ((flg? M) (op.p Arg M)) # Register or Direct 176 ((=T (cdr M)) 177 (let E (directExpr (cdr Arg)) 178 (pack 179 "(" 180 ((if (num? E) op.p op.n) (car Arg) (car M)) 181 " + " 182 E 183 ")" ) ) ) 184 ((cdr Arg) 185 (pack "(" (op.p (car Arg) (car M)) " + " @ ")") ) 186 (T (op.p (car Arg) (car M))) ) ) 187 188 (de highWord (Arg M) 189 (if (atom M) # Immediate, Register or Direct 190 0 191 (if (cdr Arg) 192 (pack "((ptr)(" (op.p (car Arg) (car M)) " + " @ " + 8))->n") 193 (pack "((ptr)(" (op.p (car Arg) (car M)) " + 8))->n") ) ) ) 194 195 ### Instruction set ### 196 (de alignSection (Align) 197 (if (== 'data *Section) 198 (when (gt0 (% (asmDataLength) 16)) 199 (conc (car *AsmData) (need (- 16 @) 0)) ) 200 (setq Align (/ Align 2)) 201 (until (= Align (& *AsmPos 7)) 202 (addCode '(NIL '(nop))) ) ) ) 203 204 (de fmtInstruction (Lst) 205 (replace (chop (str Lst)) "\"") ) 206 207 (de opcode ("X" "Args" "Body") 208 (cond 209 ((= "X" '(nop)) 0) 210 ((index "X" *BaseOpcodes) @) 211 ((assoc "X" *AsmOpcodes) (+ *OpOffs (index @ *AsmOpcodes))) 212 (T 213 (queue '*AsmOpcodes 214 (cons "X" 215 ~(as *Dbg 216 (pack 217 "fprintf(stderr, \"%ld: %s\\n\", Code<=PC && PC<Code+32767? PC-Code-1 : 0, \"" 218 (fmtInstruction "X") 219 "\");" ) ) 220 (mapcar '((S) (apply text "Args" S)) "Body") ) ) 221 (+ *OpOffs (length *AsmOpcodes)) ) ) ) 222 223 (de addCode (C) 224 (if (and *AsmCode (not (caar @))) 225 (set (car *AsmCode) C) 226 (push '*AsmCode (cons C)) ) 227 (inc '*AsmPos) ) 228 229 (de genCode Args 230 (addCode (cons (env (pop 'Args)) Args)) ) 231 232 (de baseCode (Adr) 233 (and *FPic (get *BaseCode Adr)) ) 234 235 (de absCode (Lbl) 236 (val (car (idx '*Labels Lbl))) ) 237 238 (de relCode (Adr) 239 (- (absCode Adr) 1 *AsmPos) ) 240 241 242 (asm nop () 243 (addCode '(NIL '(nop))) ) 244 245 (asm align (N) 246 (if (== 'data *Section) 247 (when (gt0 (% (asmDataLength) N)) 248 (conc (car *AsmData) (need (- N @) 0)) ) 249 (setq N (/ N 2)) 250 (while (gt0 (% *AsmPos N)) 251 (addCode '(NIL '(nop))) ) ) ) 252 253 (asm skip (N) 254 (if (== 'data *Section) 255 (conc (car *AsmData) (need N 0)) 256 (do (/ N 2) (addCode '(NIL '(nop)))) ) ) 257 258 # Move data 259 (asm ld (Dst D Src S) 260 (cond 261 ((= "A.b[0]" Dst) 262 (genCode (Dst Src S) (list 'ld Dst Src) ((op.b Src S)) 263 "A.b[0] = @1;" ) ) 264 ((= "A.b[0]" Src) 265 (genCode (Dst Src D) (list 'ld Dst Src) ((op.b Dst D)) 266 "@1 = A.b[0];" ) ) 267 ((and (not D) (pair Dst)) 268 (genCode (Src S) (list 'ld 'D Src) ((op.n Src S) (highWord Src S)) 269 "A.n = @1, C.n = @2;" ) ) 270 ((and (not S) (pair Src)) 271 (genCode (Dst D) (list 'ld Dst 'D) ((op.n Dst D) (highWord Dst D)) 272 "@1 = A.n, @2 = C.n;" ) ) 273 (T 274 (genCode (Dst D Src S) (list 'ld Dst Src) ((op.n Dst D) (op.n Src S)) 275 "@1 = @2;" ) ) ) ) 276 277 (asm ld2 (Src S) 278 (genCode (Src S) (list 'ld2 Src) ((op.a Src S)) 279 "A.n = (uint64_t)*(uint16_t*)@1;" ) ) 280 281 (asm ld4 (Src S) 282 (genCode (Src S) (list 'ld4 Src) ((op.a Src S)) 283 "A.n = (uint64_t)*(uint32_t*)@1;" ) ) 284 285 (asm ldc (Dst D Src S) 286 (genCode (Dst D Src S) (list 'ldc Dst Src) ((op.n Dst D) (op.n Src S)) 287 "if (Carry)" 288 " @1 = @2;" ) ) 289 290 (asm ldnc (Dst D Src S) 291 (genCode (Dst D Src S) (list 'ldnc Dst Src) ((op.n Dst D) (op.n Src S)) 292 "if (!Carry)" 293 " @1 = @2;" ) ) 294 295 (asm ldz (Dst D Src S) 296 (genCode (Dst D Src S) (list 'ldz Dst Src) ((op.n Dst D) (op.n Src S)) 297 "if (!Result)" 298 " @1 = @2;" ) ) 299 300 (asm ldnz (Dst D Src S) 301 (genCode (Dst D Src S) (list 'ldnz Dst Src) ((op.n Dst D) (op.n Src S)) 302 "if (Result)" 303 " @1 = @2;" ) ) 304 305 (asm lea (Dst D Src S) 306 (genCode (Dst D Src S) (list 'lea Dst Src) ((op.n Dst D) (op.a Src S)) 307 "@1 = (uint64_t)(unsigned long)@2;" ) ) 308 309 (asm st2 (Dst D) 310 (genCode (Dst D) (list 'st2 Dst) ((op.a Dst D)) 311 "*(uint16_t*)@1 = (uint16_t)A.l;" ) ) 312 313 (asm st4 (Dst D) 314 (genCode (Dst D) (list 'st4 Dst) ((op.a Dst D)) 315 "*(uint32_t*)@1 = A.l;" ) ) 316 317 (asm xchg (Dst D Dst2 D2) 318 (genCode (Dst D Dst2 D2) (list 'xchg Dst Dst2) ((op.n Dst D) (op.n Dst2 D2)) 319 "tmp.n = @1, @1 = @2, @2 = tmp.n;" ) ) 320 321 (asm movn (Dst D Src S Cnt C) 322 (genCode (Dst D Src S Cnt C) (list 'movn Dst Src Cnt) ((op.a Dst D) (op.a Src S) (op.i Cnt C)) 323 "memcpy(@1, @2, @3);" ) ) 324 325 (asm mset (Dst D Cnt C) 326 (genCode (Dst D Cnt C) (list 'mset Dst Cnt) ((op.a Dst D) (op.i Cnt C)) 327 "memset(@1, (int)A.b[0], @2);" ) ) 328 329 (asm movm (Dst D Src S End E) 330 (genCode (Dst D Src S End E) (list 'movm Dst Src End) ((op.a Dst D) (op.a Src S) (op.a End E)) 331 "memmove(@1, @2, @3 - @2);" ) ) 332 333 (asm save (Src S End E Dst D) 334 (genCode (Dst D Src S End E) (list 'save Dst Src End) ((op.a Dst D) (op.a Src S) (op.a End E)) 335 "memcpy(@1, @2, @3 - @2);" ) ) 336 337 (asm load (Dst D End E Src S) 338 (genCode (Dst D Src S End E) (list 'load Dst Src End) ((op.a Dst D) (op.a Src S) (op.a End E)) 339 "memcpy(@1, @2, @3 - @1);" ) ) 340 341 # Arithmetics 342 (asm add (Dst D Src S) 343 (cond 344 ((= Dst "S") 345 (genCode (Dst D Src S) (list 'add Dst Src) ((op.n Dst D) (op.n Src S)) 346 "@1 += @2;" ) ) 347 ((or D (atom Dst)) 348 (genCode (Dst D Src S) (list 'add Dst Src) ((op.n Dst D) (op.n Src S)) 349 "Carry = (Result = @1 += @2) < @2;" ) ) 350 (T 351 (genCode (Src S) (list 'add 'D Src) ((op.n Src S)) 352 "Carry = (A.n += @1) < @1 && ++C.n == 0;" 353 "Result = C.n;" ) ) ) ) # 'z' only for upper word 354 355 (asm addc (Dst D Src S) 356 (if (or D (atom Dst)) 357 (genCode (Dst D Src S) (list 'addc Dst Src) ((op.n Dst D) (op.n Src S)) 358 "if ((tmp.n = @2 + Carry) == 0)" 359 " Result = @1;" 360 "else" 361 " Carry = (Result = @1 += tmp.n) < tmp.n;" ) 362 (genCode (Src S) (list 'addc 'D Src) ((op.n Src S)) 363 "if ((tmp.n = @1 + Carry) == 0)" 364 " Carry = (C.n += Carry) == 0;" 365 "else if ((A.n += tmp.n) < tmp.n)" 366 " Carry = ++C.n == 0;" 367 "else" 368 " Carry = 0;" 369 "Result = C.n;" ) ) ) # 'z' only for upper word 370 371 (asm sub (Dst D Src S) 372 (if (= Dst "S") 373 (genCode (Dst D Src S) (list 'sub Dst Src) ((op.n Dst D) (op.n Src S)) 374 "@1 -= @2;" ) 375 (genCode (Dst D Src S) (list 'sub Dst Src) ((op.n Dst D) (op.n Src S)) 376 "Carry = (Result = @1 -= @2) > MAX64 - @2;" ) ) ) 377 378 (asm subc (Dst D Src S) 379 (genCode (Dst D Src S) (list 'subc Dst Src) ((op.n Dst D) (op.n Src S)) 380 "if ((tmp.n = @1 - Carry) > MAX64 - Carry)" 381 " Result = @1 = MAX64 - @2;" 382 "else" 383 " Carry = (Result = @1 = tmp.n - @2) > MAX64 - @2;" ) ) 384 385 (asm inc (Dst D) 386 (genCode (Dst D) (list 'inc Dst) ((op.n Dst D)) 387 "Result = ++@1;" ) ) 388 389 (asm dec (Dst D) 390 (genCode (Dst D) (list 'dec Dst) ((op.n Dst D)) 391 "Result = --@1;" ) ) 392 393 (asm not (Dst D) 394 (genCode (Dst D) (list 'not Dst) ((op.n Dst D)) 395 "Result = @1 = ~@1;" ) ) 396 397 (asm neg (Dst D) 398 (genCode (Dst D) (list 'neg Dst) ((op.n Dst D)) 399 "Result = @1 = -@1;" ) ) 400 401 (asm and (Dst D Src S) 402 (genCode (Dst D Src S) (list 'and Dst Src) ((op.n Dst D) (op.n Src S)) 403 "Result = @1 &= @2;" ) ) 404 405 (asm or (Dst D Src S) 406 (genCode (Dst D Src S) (list 'or Dst Src) ((op.n Dst D) (op.n Src S)) 407 "Result = @1 |= @2;" ) ) 408 409 (asm xor (Dst D Src S) 410 (genCode (Dst D Src S) (list 'xor Dst Src) ((op.n Dst D) (op.n Src S)) 411 "Result = @1 \^= @2;" ) ) 412 413 (asm off (Dst D Src S) 414 (genCode (Dst D Src S) (list 'off Dst (pack (cdr (chop Src)))) ((op.n Dst D) (op.n Src S)) 415 "Result = @1 &= @2;" ) ) 416 417 (asm test (Dst D Src S) 418 (genCode (Dst D Src S) (list 'test Dst Src) ((op.n Dst D) (op.n Src S)) 419 "Result = @1 & @2;" ) ) 420 421 (asm shl (Dst D Src S) 422 (genCode (Dst D Src S) (list 'shl Dst Src) ((op.n Dst D) (op.n Src S)) 423 "Carry = @1 >> 64 - @2 & 1;" 424 "Result = @1 <<= @2;" ) ) 425 426 (asm shr (Dst D Src S) 427 (genCode (Dst D Src S) (list 'shr Dst Src) ((op.n Dst D) (op.n Src S)) 428 "Carry = @1 >> @2 - 1 & 1;" 429 "Result = @1 >>= @2;" ) ) 430 431 (asm rol (Dst D Src S) 432 (if (=0 S) 433 (genCode (Dst D Src) (list 'rol Dst Src) ((op.n Dst D) Src) 434 "@1 = @1 << @2 | @1 >> (64 - @2);" ) 435 (genCode (Dst D Src S) (list 'rol Dst Src) ((op.n Dst D) (op.i Src S)) 436 "i = @2, @1 = @1 << i | @1 >> (64 - i);" ) ) ) 437 438 (asm ror (Dst D Src S) 439 (if (=0 S) 440 (genCode (Dst D Src) (list 'ror Dst Src) ((op.n Dst D) Src) 441 "@1 = @1 >> @2 | @1 << (64 - @2);" ) 442 (genCode (Dst D Src S) (list 'ror Dst Src) ((op.n Dst D) (op.i Src S)) 443 "i = @2, @1 = @1 >> i | @1 << (64 - i);" ) ) ) 444 445 (asm rcl (Dst D Src S) 446 (genCode (Dst D Src S) (list 'rcl Dst Src) ((op.n Dst D) (op.i Src S)) 447 "@1 = @1 << @2 | @1 >> (64 - @2);" 448 "i = @1 & 1, @1 = @1 & ~1 | Carry, Carry = i;" ) ) 449 450 (asm rcr (Dst D Src S) 451 (genCode (Dst D Src S) (list 'rcr Dst Src) ((op.n Dst D) (op.i Src S)) 452 "i = @1 & 1, @1 = @1 & ~1 | Carry, Carry = i;" 453 "@1 = @1 >> @2 | @1 << (64 - @2);" ) ) 454 455 (asm mul (Src S) 456 (genCode (Src S) (list 'mul Src) ((op.n Src S)) 457 "mul2(@1);" ) ) 458 459 (asm div (Src S) 460 (genCode (Src S) (list 'div Src) ((op.n Src S)) 461 "div2(@1);" ) ) 462 463 (asm zxt () # 8 bit -> 64 bit 464 (genCode NIL '(zxt) NIL 465 "A.n &= 0xFF;" ) ) 466 467 (asm setz () 468 (genCode NIL '(setz) NIL 469 "Carry = 0, Result = 0;" ) ) 470 471 (asm clrz () 472 (genCode NIL '(clrz) NIL 473 "Result = 1;" ) ) 474 475 (asm setc () 476 (genCode NIL '(setc) NIL 477 "Carry = 1;" ) ) 478 479 (asm clrc () 480 (genCode NIL '(clrc) NIL 481 "Carry = 0;" ) ) 482 483 # Comparisons 484 (asm cmp (Dst D Src S) 485 (cond 486 ((or (= Dst "A.b[0]") (= Src "A.b[0]")) 487 (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.b Dst D) (op.b Src S)) 488 "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) 489 ((and (= Dst "S") (= Src '(StkLimit))) 490 (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.n Dst D) (op.n Src S)) 491 "if (S.p < Stack + 4064)" 492 " emuStkErr();" 493 "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) 494 (T 495 (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.n Dst D) (op.n Src S)) 496 "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) ) ) 497 498 (asm cmpn (Dst D Src S Cnt C) 499 (genCode (Dst D Src S Cnt C) (list 'cmpn Dst Src Cnt) ((op.a Dst D) (op.a Src S) (op.i Cnt C)) 500 "Result = (uint64_t)memcmp(@1, @2, @3);" ) ) 501 502 (asm slen (Dst D Src S) 503 (genCode (Dst D Src S) (list 'slen Dst Src) ((op.n Dst D) (op.a Src S)) 504 "@1 = (uint64_t)strlen(@2);" ) ) 505 506 (asm memb (Src S Cnt C) 507 (if S 508 (genCode (Src S Cnt C) (list 'memb Src Cnt) ((op.a Src S) (op.i Cnt C)) 509 "Result = !(uint64_t)(unsigned long)memchr(@1, (int)A.b[0], @2);" ) 510 (genCode (Src S Cnt C) (list 'memb Src Cnt) ((op.a Src S) (op.i Cnt C) Cnt) 511 "if (!(Result = !(tmp.p = (uint8_t*)memchr(@1, (int)A.b[0], @2))))" 512 " @3.n -= tmp.p - @1 + 1, @1 = tmp.p + 1;" ) ) ) 513 514 (asm null (Src S) 515 (genCode (Src S) (list 'null Src) ((op.n Src S)) 516 "Carry = 0, Result = @1;" ) ) 517 518 (asm nulp (Src S) 519 (genCode (Src S) (list 'nulp Src) ((op.i Src S)) 520 "Result = @1;" ) ) 521 522 (asm nul4 () 523 (genCode NIL '(nul4) NIL 524 "Carry = 0, Result = (int32_t)A.l;" ) ) 525 526 # Byte addressing 527 (asm set (Dst D Src S) 528 (genCode (Dst D Src S) (list 'set Dst Src) ((op.b Dst D) (op.b Src S)) 529 "@1 = @2;" ) ) 530 531 (asm nul (Src S) 532 (genCode (Src S) (list 'nul Src) ((op.b Src S)) 533 "Carry = 0, Result = @1;" ) ) 534 535 # Types 536 (asm cnt (Src S) 537 (genCode (Src S) (list 'cnt Src) ((op.b Src S)) 538 "Result = @1 & 2;" ) ) 539 540 (asm big (Src S) 541 (genCode (Src S) (list 'big Src) ((op.b Src S)) 542 "Result = @1 & 4;" ) ) 543 544 (asm num (Src S) 545 (genCode (Src S) (list 'num Src) ((op.b Src S)) 546 "Result = @1 & 6;" ) ) 547 548 (asm sym (Src S) 549 (genCode (Src S) (list 'sym Src) ((op.b Src S)) 550 "Result = @1 & 8;" ) ) 551 552 (asm atom (Src S) 553 (genCode (Src S) (list 'atom Src) ((op.b Src S)) 554 "Result = @1 & 14;" ) ) 555 556 # Flow Control 557 (de localAddr (Adr) 558 (or 559 (pre? "." Adr) # Local label ".1" 560 (and 561 (cdr (setq Adr (split (chop Adr) "_"))) # Local jump "foo_22" 562 (= *Label (pack (glue "_" (head -1 Adr)))) 563 (format (last Adr)) ) ) ) 564 565 (asm call (Adr A) 566 (nond 567 (A # Absolute 568 (cond 569 ((baseCode Adr) 570 (genCode (Adr) (list 'call Adr) ((baseCode Adr)) 571 "S.p -= 8, *(uint16_t**)S.p = PC;" 572 "PC = Code + @1;" ) ) 573 (*FPic 574 (genCode (Adr) (list 'call Adr) ((absCode Adr)) 575 "S.p -= 8, *(uint16_t**)S.p = PC;" 576 "PC = LibCode + @1;" ) ) 577 (T 578 (genCode (Adr) (list 'call Adr) ((absCode Adr)) 579 "S.p -= 8, *(uint16_t**)S.p = PC;" 580 "PC = Code + @1;" ) ) ) ) 581 ((=T A) # Indexed: Ignore SUBR 582 (genCode (Adr A) (list 'call (list Adr)) (Adr) 583 "S.p -= 8, *(uint16_t**)S.p = PC;" 584 "PC = (uint16_t*)@1.p;" ) ) 585 (NIL # Indirect 586 (genCode (Adr A) (list 'call (list Adr)) ((op.p Adr A)) 587 "S.p -= 8, *(uint16_t**)S.p = PC;" 588 "PC = *(uint16_t**)@1;" ) ) ) ) 589 590 (asm jmp (Adr A) 591 (nond 592 (A # Absolute 593 (cond 594 ((localAddr Adr) 595 (genCode (Adr) (list 'jmp (relCode Adr)) ((relCode Adr)) 596 "PC += @1;" ) ) 597 ((baseCode Adr) 598 (genCode (Adr) (list 'jmp Adr) ((baseCode Adr)) 599 "PC = Code + @1;" ) ) 600 (*FPic 601 (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) 602 "PC = LibCode + @1;" ) ) 603 (T 604 (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) 605 "PC = Code + @1;" ) ) ) ) 606 ((=T A) # Indexed: Ignore SUBR 607 (genCode (Adr A) (list 'jmp (list Adr)) (Adr) 608 "PC = (uint16_t*)@1.p;" ) ) 609 (NIL # Indirect 610 (genCode (Adr A) (list 'jmp (list Adr)) ((op.p Adr A)) 611 "PC = *(uint16_t**)@1;" ) ) ) ) 612 613 (de _jmp (Opc Test) 614 (nond 615 (A # Absolute 616 (cond 617 ((localAddr Adr) 618 (genCode (Adr Opc Test) (list Opc (relCode Adr)) ((relCode Adr) Test) 619 "if (@2)" 620 " PC += @1;" ) ) 621 ((baseCode Adr) 622 (genCode (Adr Opc Test) (list Opc Adr) ((baseCode Adr) Test) 623 "if (@2)" 624 " PC = Code + @1;") ) 625 (*FPic 626 (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) 627 "if (@2)" 628 " PC = LibCode + @1;") ) 629 (T 630 (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) 631 "if (@2)" 632 " PC = Code + @1;") ) ) ) 633 ((=T A) # Indexed: Ignore SUBR 634 (genCode (Adr Opc Test) (list Opc Adr) (Adr Test) 635 "if (@2)" 636 " PC = (uint16_t*)@1.p;" ) ) 637 (NIL # Indirect 638 (genCode (Adr A Opc Test) (list Opc (list Adr)) ((op.p Adr A) Test) 639 "if (@2)" 640 " PC = (uint16_t**)@1;" ) ) ) ) 641 642 (asm jz (Adr A) 643 (_jmp "jz" "!Result") ) 644 645 (asm jeq (Adr A) 646 (_jmp "jz" "!Result") ) 647 648 (asm jnz (Adr A) 649 (_jmp "jnz" "Result") ) 650 651 (asm jne (Adr A) 652 (_jmp "jnz" "Result") ) 653 654 (asm js (Adr A) 655 (_jmp "js" "(int64_t)Result < 0") ) 656 657 (asm jns (Adr A) 658 (_jmp "jns" "(int64_t)Result >= 0") ) 659 660 (asm jsz (Adr A) 661 (_jmp "jsz" "(int64_t)Result <= 0") ) 662 663 (asm jnsz (Adr A) 664 (_jmp "jnsz" "(int64_t)Result > 0") ) 665 666 (asm jc (Adr A) 667 (_jmp "jc" "Carry") ) 668 669 (asm jlt (Adr A) 670 (_jmp "jc" "Carry") ) 671 672 (asm jnc (Adr A) 673 (_jmp "jnc" "!Carry") ) 674 675 (asm jge (Adr A) 676 (_jmp "jnc" "!Carry") ) 677 678 (asm jcz (Adr A) 679 (_jmp "jcz" "!Result || Carry") ) 680 681 (asm jle (Adr A) 682 (_jmp "jcz" "!Result || Carry") ) 683 684 (asm jncz (Adr A) 685 (_jmp "jncz" "Result && !Carry") ) 686 687 (asm jgt (Adr A) 688 (_jmp "jncz" "Result && !Carry") ) 689 690 (asm ret () 691 (genCode NIL '(ret) NIL 692 "PC = *(uint16_t**)S.p, S.p += 8;" ) ) 693 694 # Floating point 695 (asm ldd () 696 (genCode NIL '(ldd) NIL 697 "A.d = *(double*)C.p;" ) ) 698 699 (asm ldf () 700 (genCode NIL '(ldf) NIL 701 "A.f = *(float*)C.p;" ) ) 702 703 (asm fixnum () 704 (genCode NIL '(fixnum) ((directExpr "TSym") (directExpr "Nil")) 705 "if (E.b[0] & 8)" 706 " A.d = A.f * (float)(E.n >> 4);" 707 "else" 708 " A.d = A.d * (double)(E.n >> 4);" 709 "if (isinf(A.d) == 1 || A.d > (double)0xFFFFFFFFFFFFFFFLL)" 710 " E.p = @1;" 711 "else if (isnan(A.d) || isinf(A.d) == -1 || A.d < (double)-0xFFFFFFFFFFFFFFFLL)" 712 " E.p = @2;" 713 "else if (A.d >= 0)" 714 " E.n = (uint64_t)(A.d + 0.5) << 4 | 2;" 715 "else" 716 " E.n = (uint64_t)(0.5 - A.d) << 4 | 10;" ) ) 717 718 (asm float () 719 (genCode NIL '(float) ((directExpr "Nil")) 720 "if (A.b[0] & 8) {" 721 " if (((ptr)X.p)->n & 2) {" 722 " tmp.f = (float)(((ptr)X.p)->n >> 4) / (float)(A.n >> 4);" 723 " if (((ptr)X.p)->n & 8)" 724 " tmp.f = -tmp.f;" 725 " }" 726 " else" 727 " tmp.f = X.p == @1? -INFINITY : INFINITY;" 728 "}" 729 "else {" 730 " if (((ptr)X.p)->n & 2) {" 731 " tmp.d = (double)(((ptr)X.p)->n >> 4) / (double)(A.n >> 4);" 732 " if (((ptr)X.p)->n & 8)" 733 " tmp.d = -tmp.d;" 734 " }" 735 " else" 736 " tmp.d = X.p == @1? -INFINITY : INFINITY;" 737 "}" ) ) 738 739 (asm std () 740 (genCode NIL '(std) NIL 741 "*(double*)Z.p = tmp.d;" ) ) 742 743 (asm stf () 744 (genCode NIL '(stf) NIL 745 "*(float*)Z.p = tmp.f;" ) ) 746 747 # C-Calls 748 (de *C-Params # Function return value and parameters 749 (getpid i) 750 (getenv p p) 751 (setenv i p p i) 752 (isatty i i) 753 (tcgetattr i i "struct termios") 754 (tcsetattr i i i "struct termios") 755 (tcsetpgrp - i i) 756 (signal p i f) 757 (sigfillset - "sigset_t") 758 (sigemptyset - "sigset_t") 759 (sigaddset - "sigset_t" i) 760 (sigprocmask - i "sigset_t" "sigset_t") 761 (sigaction - i "struct sigaction" "struct sigaction") 762 (gettimeofday - -2 "struct timezone") 763 (malloc p i) 764 (realloc p p i) 765 (fork i) 766 (getpgrp i) 767 (setpgid - i i) 768 (execvp i p 0) 769 (kill i i i) 770 (raise - i) 771 (alarm i i) 772 (waitpid i i "int" i) 773 (free - p) 774 (stat i p "struct stat") 775 (lstat i p "struct stat") 776 (fcntl i i i p) 777 (pipe i "int") 778 (select i i "fd_set" "fd_set" "fd_set" (2 . -2)) 779 (open i p i i) 780 (dup i i) 781 (dup2 - i i) 782 (read n i p i) 783 (write n i p i) 784 (lseek n i n i) 785 (pread n i p i n) 786 (pwrite n i p i n) 787 (close i i) 788 (fopen p p p) 789 (freopen p p p p) 790 (getc_unlocked i "FILE") 791 (putc_unlocked - i "FILE") 792 (fread i p i i "FILE") 793 (fwrite i p i i "FILE") 794 (fileno i "FILE") 795 (fseek i "FILE" n i) 796 (ftruncate i i n) 797 (fflush - "FILE") 798 (fsync i i) 799 (feof i "FILE") 800 (fclose - "FILE") 801 (socket i i i i) 802 (setsockopt i i i i p i) 803 (htons i i) 804 (ntohs i i) 805 (inet_ntop - i p p i) 806 (bind i i "struct sockaddr" i) 807 (listen i i i) 808 (getsockname i i "struct sockaddr" "socklen_t") 809 (getaddrinfo i p p "struct addrinfo" "struct addrinfo") 810 (getnameinfo i "struct sockaddr" i p i p i i) 811 (freeaddrinfo - "struct addrinfo") 812 (accept i i "struct sockaddr" "socklen_t") 813 (connect i i "struct sockaddr" i) 814 (recv i i p i i) 815 (sendto - i p i i "struct sockaddr" i) 816 (strdup p p) 817 (dlopen p p i) 818 (dlsym p "void" p) 819 (getcwd p p) 820 (chdir i p) 821 (opendir p p) 822 (readdir p "DIR") 823 (closedir - "DIR") 824 (time - "time_t") 825 (times - "struct tms") 826 (usleep - i) 827 (gmtime p "time_t") 828 (localtime p "time_t") 829 (printf - p) 830 (fprintf - "FILE" p) 831 (snprintf - p i p p) 832 (strerror p i) 833 (dlerror p) 834 (exit - i) 835 # src64/sys/emu.code.l 836 (errno_A -) 837 (errnoC -) 838 (wifstoppedS_F -) 839 (wifsignaledS_F -) 840 (wtermsigS_A n) ) 841 842 (de ccArg (P S O P2) 843 (and (pair P) (setq P (car @))) 844 (and (pair P2) (setq P2 (car @))) 845 (case P 846 (p (op.p S O)) 847 (n (op.n S O)) 848 (i (op.i S O)) 849 (f (sysFun S O)) 850 (lea 851 (pack 852 (and 853 P2 854 (n== 'p P2) 855 (if (num? P2) 856 "(void*)" 857 (pack "(" P2 "*)") ) ) 858 (op.a S O) ) ) 859 (T 860 (nond 861 (P (op.i S O)) 862 ((num? P) (pack "(" P "*)" (op.p S O))) 863 ((ge0 P) (pack "(void*)" (op.p S O))) 864 (NIL (pack "argv(" @ ", (ptr)" (op.p S O) ")")) ) ) ) ) 865 866 (de _genCC Body 867 (addCode 868 (cons 869 (env '(Adr A Arg M Par)) 870 '(list 'cc Adr Arg) 871 (list 872 'Adr 873 (list 'glue ", " Args) 874 (list 'extract 875 ''((A P) 876 (when (lt0 (fin P)) 877 (pack " retv(" (abs @) "," 878 (if (pre? "argv(" A) 879 (member " " (chop A)) 880 (pack " " A ")") ) 881 ";" ) ) ) 882 Args 883 '(cdr Par) ) ) 884 Body ) ) ) 885 886 (de _natCC (I N Typ Arg) 887 (if (=0 N) 888 (link 889 (pack 890 (need (inc I) " ") 891 (case (car (setq Typ (reverse Typ))) 892 (float "A.f = (*(float") 893 (double "A.d = (*(double") 894 (T "A.n = (*(uint64_t") ) 895 " (*)(" 896 (glue "," Typ) 897 "))@1.p)(" 898 (glue ", " (reverse Arg)) 899 ");" ) ) 900 (let N (dec N) 901 (link 902 (pack 903 (need (inc I) " ") 904 "if (((ptr)(S.p + " 905 (* 16 I) 906 "))->n == 0)" ) ) 907 (_natCC (inc I) N 908 (cons 'long Typ) 909 (cons 910 (pack "((ptr)(S.p + " (+ 8 (* 16 I)) "))->n") 911 Arg ) ) 912 (link 913 (pack 914 (need (inc I) " ") 915 "else if (((ptr)(S.p + " 916 (* 16 I) 917 "))->n & 8)" ) ) 918 (_natCC (inc I) N 919 (cons 'float Typ) 920 (cons 921 (pack "(float)dbl(" (* 16 I) ")") 922 Arg ) ) 923 (link (pack (need (inc I) " ") "else")) 924 (_natCC (inc I) N 925 (cons 'double Typ) 926 (cons 927 (pack "dbl(" (* 16 I) ")") 928 Arg ) ) ) ) ) 929 930 (asm cc (Adr A Arg M) 931 (if (lst? Arg) 932 (let 933 (Par (cdr (assoc Adr *C-Params)) 934 Args 935 '(let (P (cdr Par) Lea) 936 (mapcan 937 '((S O) 938 (cond 939 ((== '& S) (on Lea)) 940 ((== 'pop S) 941 (cons 942 (pack 943 "(S.p += 8, " 944 (ccArg (pop 'P) '("S" . -8) '(NIL . 0)) 945 ")" ) ) ) 946 (Lea 947 (off Lea) 948 (cons (ccArg 'lea S O (pop 'P))) ) 949 (T (cons (ccArg (pop 'P) S O))) ) ) 950 Arg 951 M ) ) ) 952 (case (car Par) 953 (- (_genCC "@1(@2);@3")) 954 (p (_genCC "A.n = (uint64_t)(uintptr_t)(uint8_t*)@1(@2);@3")) 955 (n (_genCC "A.n = (uint64_t)@1(@2);@3")) 956 (i (_genCC "A.n = (uint64_t)(uint32_t)@1(@2);@3")) 957 (T (quit "Unknown C function" Adr)) ) ) 958 (addCode 959 (cons 960 (env '(Adr Arg)) 961 '(list 'cc (list Adr) Arg) 962 '(Adr Arg) 963 (make 964 (link "if ((tmp.p = S.p) == @2.p)") 965 (_natCC 0 0) 966 (for N 6 967 (link "else if ((tmp.p += 16) == @2.p) {") 968 (_natCC 0 N) 969 (link "}") ) 970 (link 971 "else" 972 " A.n = (*(uint64_t (*)(long,long,long,long,long,long,long,long))Y.p)(((ptr)(S.p + 8))->n, ((ptr)(S.p + 24))->n, ((ptr)(S.p + 40))->n, ((ptr)(S.p + 56))->n, ((ptr)(S.p + 72))->n, ((ptr)(S.p + 88))->n, ((ptr)(S.p + 104))->n, ((ptr)(S.p + 120))->n);" ) ) ) ) ) ) 973 974 (asm func () 975 (genCode NIL '(func) ((directExpr "cbl1")) 976 "E.n = (uint64_t)(unsigned long)(void(*)())cbl[(E.p-@1)/2];" ) ) 977 978 (asm begin ()) 979 980 (asm return () 981 (genCode NIL '(return) NIL 982 "return;" ) ) # Terminate 'run' 983 984 # Stack Manipulations 985 (asm push (Src S) 986 (cond 987 ((=T Src) 988 (genCode NIL '(push F) NIL 989 "S.p -= 8, ((ptr)S.p)->n = (Result & ~1) | (Result & 0xFFFFFFFF) << 1 | Carry;" ) ) 990 ((= "S" Src) 991 (genCode (Src S) '(push S) NIL 992 "tmp.n = S.n, S.p -= 8, ((ptr)S.p)->n = tmp.n;" ) ) 993 (T 994 (genCode (Src S) (list 'push Src) ((op.n Src S)) 995 "S.p -= 8, ((ptr)S.p)->n = @1;" ) ) ) ) 996 997 (asm pop (Dst D) 998 (if (=T Dst) 999 (genCode NIL '(pop F) NIL 1000 "Carry = ((ptr)S.p)->n & 1, Result = ((ptr)S.p)->n & ~1, S.p += 8;" ) 1001 (genCode (Dst D) (list 'pop Dst) ((op.n Dst D)) 1002 "@1 = ((ptr)S.p)->n, S.p += 8;" ) ) ) 1003 1004 (asm link () 1005 (genCode NIL '(link) NIL 1006 "S.p -= 8, ((ptr)S.p)->n = L.n, L.p = S.p;" ) ) 1007 1008 (asm tuck (Src S) 1009 (genCode (Src S) (list 'tuck Src) ((op.n Src S)) 1010 "L.p = ((ptr)S.p)->p, ((ptr)S.p)->n = @1;" ) ) 1011 1012 (asm drop () 1013 (genCode NIL '(drop) NIL 1014 "S.p = ((ptr)L.p)->p, L.p = ((ptr)S.p)->p, S.p += 8;" ) ) 1015 1016 # Evaluation 1017 (asm eval () 1018 (genCode NIL '(eval) ((absCode "evListE_E")) 1019 "if (!(E.b[0] & 6))" 1020 " if (E.b[0] & 8)" 1021 " E = *(ptr)E.p;" 1022 " else {" 1023 " S.p -= 8, *(uint16_t**)S.p = PC;" 1024 " PC = Code + @1;" 1025 " }" ) ) 1026 1027 (asm eval+ () 1028 (genCode NIL '(eval+) ((absCode "evListE_E")) 1029 "if (!(E.b[0] & 6))" 1030 " if (E.b[0] & 8)" 1031 " E = *(ptr)E.p;" 1032 " else {" 1033 " S.p -= 8, ((ptr)S.p)->n = L.n, L.p = S.p;" 1034 " S.p -= 8, *(uint16_t**)S.p = PC;" 1035 " S.p -= 8, *(uint16_t**)S.p = Code + 0;" # <eval+> 1036 " PC = Code + @1;" 1037 " }" ) ) 1038 1039 (asm eval/ret () 1040 (genCode NIL '(eval/ret) ((absCode "evListE_E")) 1041 "if (E.b[0] & 14) {" 1042 " if (!(E.b[0] & 6))" 1043 " E = *(ptr)E.p;" 1044 " PC = *(uint16_t**)S.p, S.p += 8;" 1045 "}" 1046 "else" 1047 " PC = Code + @1;" ) ) 1048 1049 (asm exec (Reg) 1050 (let Ofs (case Reg (X 1) (Y 2) (Z 3)) 1051 (unless *FPic 1052 (con 1053 (cdddr (caar (tail (inc Ofs) *AsmCode))) 1054 (cons (text "goto exec@1;" Reg)) ) ) 1055 (genCode (Reg Ofs) (list 'exec Reg) ((absCode "evListE_E") Reg Ofs) 1056 "do {" 1057 " E = *(ptr)@2.p;" 1058 " if (!(E.b[0] & 14)) {" 1059 " S.p -= 8, *(uint16_t**)S.p = PC;" 1060 " S.p -= 8, *(uint16_t**)S.p = Code + 1;" # <exec> 1061 " PC = Code + @1;" 1062 " break;" 1063 " }" 1064 "exec@2:" 1065 " @2.p = ((ptr)(@2.p + 8))->p;" 1066 "} while (!(@2.b[0] & 14));" ) ) ) 1067 1068 (asm prog (Reg) 1069 (let Ofs (case Reg (X 4) (Y 5) (Z 6)) 1070 (unless *FPic 1071 (con 1072 (cdddr (caar (tail (inc Ofs) *AsmCode))) 1073 (cons (text "goto prog@1;" Reg)) ) ) 1074 (genCode (Reg Ofs) (list 'prog Reg) ((absCode "evListE_E") Reg Ofs) 1075 "do {" 1076 " E = *(ptr)@2.p;" 1077 " if (!(E.b[0] & 6)) {" 1078 " if (E.b[0] & 8)" 1079 " E = *(ptr)E.p;" 1080 " else {" 1081 " S.p -= 8, *(uint16_t**)S.p = PC;" 1082 " S.p -= 8, *(uint16_t**)S.p = Code + @3;" # <progN> 1083 " PC = Code + @1;" 1084 " break;" 1085 " }" 1086 " }" 1087 "prog@2:" 1088 " @2.p = ((ptr)(@2.p + 8))->p;" 1089 "} while (!(@2.b[0] & 14));" ) ) ) 1090 1091 # System 1092 (asm initData ()) 1093 1094 (asm initCode ()) 1095 1096 (asm initMain ()) # Done explicitly in 'main' 1097 1098 (asm initLib () 1099 (genCode NIL '(initLib) NIL 1100 "A.n = (uint64_t)(unsigned long)*(uint8_t**)A.p;" ) ) 1101 1102 ### Optimizer ### 1103 # Replace the the next 'cnt' elements with 'lst' 1104 (de optimize (Lst)) #> (cnt . lst) 1105 1106 ### Decoration ### 1107 (de prolog (File) 1108 (if *FPic 1109 (in "emu.symtab" 1110 (setq 1111 *BaseData (read) 1112 *BaseCode (read) 1113 *BaseOpcodes (make (while (read) (chain @))) 1114 *OpOffs (length *BaseOpcodes) ) ) 1115 (genCode NIL '(<eval+>) NIL # Code + 0 1116 "PC = *(uint16_t**)S.p, S.p += 8;" 1117 "L.p = ((ptr)S.p)->p, S.p += 8;" ) 1118 (genCode NIL '(<execX>) NIL # Code + 1 1119 "PC = *(uint16_t**)S.p, S.p += 8;" ) 1120 (genCode NIL '(<execY>) NIL # Code + 2 1121 "PC = *(uint16_t**)S.p, S.p += 8;" ) 1122 (genCode NIL '(<execZ>) NIL # Code + 3 1123 "PC = *(uint16_t**)S.p, S.p += 8;" ) 1124 (genCode NIL '(<progX>) NIL # Code + 4 1125 "PC = *(uint16_t**)S.p, S.p += 8;" ) 1126 (genCode NIL '(<progY>) NIL # Code + 5 1127 "PC = *(uint16_t**)S.p, S.p += 8;" ) 1128 (genCode NIL '(<progZ>) NIL # Code + 6 1129 "PC = *(uint16_t**)S.p, S.p += 8;" ) ) 1130 (mapc prinl 1131 (quote 1132 NIL 1133 "#include <stdio.h>" 1134 "#include <stdint.h>" 1135 "#include <stdlib.h>" 1136 "#include <unistd.h>" 1137 "#include <limits.h>" 1138 "#include <string.h>" 1139 "#include <math.h>" 1140 "#include <errno.h>" 1141 "#include <fcntl.h>" 1142 "#include <dirent.h>" 1143 "#include <signal.h>" 1144 "#include <dlfcn.h>" 1145 "#include <time.h>" 1146 "#include <sys/types.h>" 1147 "#include <sys/time.h>" 1148 "#include <sys/times.h>" 1149 "#include <sys/stat.h>" 1150 "#include <sys/wait.h>" 1151 "#include <sys/socket.h>" 1152 NIL 1153 "#define MAX8 ((uint8_t)-1)" 1154 "#define MAX64 ((uint64_t)-1)" 1155 "#define STACK (8 * 1024 * 1024)" 1156 NIL 1157 "typedef union op {" 1158 " uint64_t n;" ) ) 1159 (if (or *LittleEndian *Bits64) 1160 (prinl " uint8_t *p;") 1161 (mapc prinl 1162 (quote 1163 " struct {" 1164 " uint32_t u;" 1165 " uint8_t *p;" 1166 " };" ) ) ) 1167 (prinl " uint8_t b[8];") 1168 (if *LittleEndian 1169 (prinl " struct {uint32_t l, h;};") 1170 (prinl " struct {uint32_t h, l;};") ) 1171 (prinl " float f;") 1172 (prinl " double d;") 1173 (prinl "} op, *ptr;") 1174 (prinl) 1175 (mapc prinl 1176 (if *FPic 1177 (quote 1178 "extern uint16_t Code[];" 1179 "static uint16_t LibCode[];" 1180 NIL 1181 "extern uint16_t *PC;" 1182 "extern uint8_t *Stack;" 1183 "extern op A, C, E, X, Y, Z, L, S;" 1184 "extern uint64_t Result;" 1185 "extern int Carry;" 1186 "extern void mul2(uint64_t);" 1187 "extern void div2(uint64_t);" 1188 "extern uint64_t begin(int,long,long,long,long,long,long);" 1189 "extern void *argv(int,ptr);" 1190 "extern void retv(int,ptr);" 1191 NIL 1192 "extern op Data[];" 1193 NIL 1194 "static op LibData[] = {" ) 1195 (quote 1196 "uint16_t Code[];" 1197 NIL 1198 "uint16_t *PC;" 1199 "uint8_t *Stack;" 1200 "op A, C, E, X, Y, Z, L, S;" 1201 "uint64_t Result;" 1202 "int Carry;" 1203 NIL 1204 "void emuStkErr(void) {" 1205 " fprintf(stderr, \"Emulator stack error\\n\");" 1206 " exit(-99);" 1207 "}" 1208 NIL 1209 "static void run(int);" 1210 NIL 1211 "void mul2(uint64_t src) {" 1212 " uint32_t h = src >> 32;" 1213 " uint32_t l = (uint32_t)src;" 1214 " op a, b;" 1215 NIL 1216 " a.n = (uint64_t)A.l * l;" 1217 " b.n = (uint64_t)A.h * l;" 1218 " C.n = (uint64_t)b.h + ((a.h += b.l) < b.l);" 1219 " b.n = (uint64_t)A.l * h;" 1220 " C.n += (uint64_t)b.h + ((a.h += b.l) < b.l);" 1221 " C.n += (uint64_t)A.h * h;" 1222 " A.n = a.n;" 1223 "}" 1224 NIL 1225 "void div2(uint64_t src) {" 1226 " uint64_t vn0, vn1, q1, q0, rhat;" 1227 " int s;" 1228 NIL 1229 " if (C.n >= src)" 1230 " A.n = C.n = MAX64;" # Overflow 1231 " else {" 1232 " s = 0;" 1233 " while ((int64_t)src > 0) {" # Normalize 1234 " C.n = (C.n << 1) + ((int64_t)A.n < 0);" # Shift dividend left 1235 " A.n <<= 1;" 1236 " src <<= 1;" # and divisor 1237 " ++s;" 1238 " }" 1239 " vn1 = src >> 32;" # Split divisor into high 1240 " vn0 = (uint32_t)src;" # and low 32 bits 1241 " q1 = C.n / vn1;" # First quotient digit 1242 " rhat = C.n - q1 * vn1;" 1243 NIL 1244 " while (q1 >> 32 || q1 * vn0 > (rhat << 32) + A.h) {" 1245 " --q1;" 1246 " if ((rhat += vn1) >> 32)" 1247 " break;" 1248 " }" 1249 " C.n = (C.n << 32) + A.h - q1 * src;" 1250 " q0 = C.n / vn1;" # Second quotient digit 1251 " rhat = C.n - q0 * vn1;" 1252 NIL 1253 " while (q0 >> 32 || q0 * vn0 > (rhat << 32) + A.l) {" 1254 " --q0;" 1255 " if ((rhat += vn1) >> 32)" 1256 " break;" 1257 " }" 1258 " C.n = ((C.n << 32) + A.l - q0 * src) >> s;" # Remainder 1259 " A.n = (q1 << 32) + q0;" # Quotient 1260 " }" 1261 "}" 1262 NIL 1263 "uint64_t begin(int i, long a, long c, long e, long x, long y, long z) {" 1264 " uint64_t res;" 1265 NIL 1266 " S.p -= 8, *(uint16_t**)S.p = PC;" 1267 " S.p -= 8, ((ptr)S.p)->l = Carry;" 1268 " S.p -= 8, ((ptr)S.p)->n = Result;" 1269 " S.p -= 8, *(ptr)S.p = Z, Z.n = z;" 1270 " S.p -= 8, *(ptr)S.p = Y, Y.n = y;" 1271 " S.p -= 8, *(ptr)S.p = X, X.n = x;" 1272 " S.p -= 8, *(ptr)S.p = E, E.n = e;" 1273 " S.p -= 8, *(ptr)S.p = C, C.n = c;" 1274 " S.p -= 8, *(ptr)S.p = A, A.n = a;" 1275 " run(i);" 1276 " res = A.n;" 1277 " A = *(ptr)S.p, S.p += 8;" 1278 " C = *(ptr)S.p, S.p += 8;" 1279 " E = *(ptr)S.p, S.p += 8;" 1280 " X = *(ptr)S.p, S.p += 8;" 1281 " Y = *(ptr)S.p, S.p += 8;" 1282 " Z = *(ptr)S.p, S.p += 8;" 1283 " Result = ((ptr)S.p)->n, S.p += 8;" 1284 " Carry = ((ptr)S.p)->l, S.p += 8;" 1285 " PC = *(uint16_t**)S.p, S.p += 8;" 1286 " return res;" 1287 "}" 1288 NIL 1289 "void *argv(int i, ptr p) {" 1290 " if (p) {" 1291 " if (i == 0)" 1292 " while (((uint8_t**)p)[i] = p[i].p)" 1293 " ++i;" 1294 " else" 1295 " while (--i >= 0)" 1296 " ((uint8_t**)p)[i] = p[i].p;" 1297 " }" 1298 " return p;" 1299 "}" 1300 NIL 1301 "void retv(int i, ptr p) {" 1302 " if (p)" 1303 " while (--i >= 0)" 1304 " p[i].n = (uint64_t)(unsigned long)((uint8_t**)p)[i];" 1305 "}" 1306 NIL 1307 "op Data[] = {" ) ) ) ) 1308 1309 (de prOpcode (I X) 1310 (prinl 1311 (align 7 X) 1312 ", // " 1313 (align 7 (dec I)) 1314 ": " 1315 (if (=0 X) 1316 "nop" 1317 (fmtInstruction 1318 (or 1319 (get *BaseOpcodes X) 1320 (get *AsmOpcodes (- X *OpOffs) 1) ) ) ) ) ) 1321 1322 (de epilog (File) 1323 (setq 1324 *AsmData (flip *AsmData) 1325 *AsmCode (flip *AsmCode) ) 1326 (let *AsmPos 0 1327 (for X *AsmCode 1328 (set X 1329 (job (env (caar X)) 1330 (opcode 1331 (eval (cadar X)) 1332 (mapcar eval (caddar X)) 1333 (cdddar X) ) ) ) 1334 (inc '*AsmPos) ) ) 1335 (let Bytes NIL 1336 (for D *AsmData 1337 (prin 1338 " /* " 1339 (align -10 (car D)) 1340 (align 5 (cadr D)) 1341 " */" ) 1342 (and Bytes (cddr D) (space 8)) 1343 (for (I . X) (cddr D) 1344 (cond 1345 ((pair X) 1346 (and Bytes (quit "Unaligned word" (car D))) 1347 (prin " {.n = " (car X) "},") ) 1348 ((sym? X) 1349 (and Bytes (quit "Unaligned word" (car D))) 1350 (cond 1351 ((pre? ".+" X) 1352 (let N (+ (cadr D) (format (cddr (chop X)))) 1353 (for ((J . L) (cddr D) (> I J) (cdr L)) 1354 (NIL (> I J)) # Temporary (03oct12abu) 1355 (inc 'N (if (num? (car L)) 1 8)) ) 1356 (prin 1357 " {.p = (uint8_t*)" 1358 (and *FPic "Lib") 1359 "Data+" 1360 N 1361 "}," ) ) ) 1362 ((asoq X *AsmData) 1363 (let N @ 1364 (prin 1365 " {.p = (uint8_t*)" 1366 (and *FPic "Lib") 1367 "Data+" 1368 (cadr N) 1369 "}," ) ) ) 1370 ((absCode X) 1371 (let N @ 1372 (prin 1373 " {.p = (uint8_t*)(" 1374 (and *FPic "Lib") 1375 "Code+" 1376 N 1377 ")}," ) ) ) 1378 (T (quit "No value" X)) ) ) 1379 (Bytes 1380 (prin (and (> I 1) ", ") X) 1381 (when (= 8 (inc 'Bytes)) 1382 (prin "}},") 1383 (off Bytes) ) ) 1384 (T 1385 (prin " {.b = {" X) 1386 (one Bytes) ) ) ) 1387 (and Bytes (cddr D) (prin ",")) 1388 (prinl) ) 1389 (when Bytes 1390 (space 26) 1391 (prinl "}}") ) ) 1392 (prinl "};") 1393 (prinl) 1394 (unless *FPic 1395 (for I 24 1396 (sysFun (pack "cbl" I) T) ) ) 1397 (when *SysFun 1398 (mapc prinl (flip @)) 1399 (prinl) ) 1400 (unless *FPic 1401 (prinl 1402 "static void (*cbl[])() = {" 1403 (glue "," 1404 (make 1405 (for I 24 1406 (link (pack "fun" (absCode (pack "cbl" I)))) ) ) ) 1407 "};" ) 1408 (prinl) 1409 (prinl "long lisp(char *p, long a, long b, long c, long d, long e) {") 1410 (prinl " return (long)begin(" (absCode "lisp") ", (long)p, a, b, c, d, e);") 1411 (prinl "}") 1412 (prinl) ) 1413 (prinl 1414 (and *FPic "static ") 1415 "uint16_t " 1416 (and *FPic "Lib") 1417 "Code[] = {" ) 1418 (for (I . X) *AsmCode 1419 (for C (cdr X) 1420 (unless (pre? "." C) # Omit local labels 1421 (prinl " // " C ":") ) ) 1422 (prOpcode I (car X)) ) 1423 (prinl "};") 1424 (prinl) 1425 (when *FPic 1426 (for S (by val sort (idx '*Labels)) 1427 (unless (pre? "." S) # Omit local labels 1428 (prinl "uint16_t *" S " = LibCode + " (val S) ";") ) ) 1429 (prinl) ) 1430 (if *FPic 1431 (mapc prinl 1432 (quote 1433 "extern void (*FirstLib)(void);" 1434 "static void (*NextLib)(void);" 1435 NIL 1436 "static void opcodes(void) {" 1437 " op i, tmp;" 1438 NIL 1439 " switch (PC[-1]) {" ) ) 1440 (mapc prinl 1441 (quote 1442 "double dbl(int i) {" 1443 " uint64_t s = ((ptr)(S.p + i))->n;" 1444 NIL 1445 " if (s & 2) {" 1446 " uint64_t m = ((ptr)(S.p + i + 8))->n;" 1447 " double d = (double)(m >> 4) / (double)(s >> 4);" 1448 " return m & 8? -d : d;" 1449 " }" ) ) 1450 (prinl 1451 " return ((ptr)(S.p + i))->p == " 1452 (directExpr "Nil") 1453 "? -INFINITY : INFINITY;" ) 1454 (mapc prinl 1455 (quote 1456 "}" 1457 NIL 1458 "void (*FirstLib)(void);" 1459 NIL 1460 "static void run(int i) {" 1461 " op tmp;" 1462 NIL 1463 " PC = Code + i;" 1464 " for (;;) {" 1465 " switch (*PC++) {" 1466 " case 0: // nop" 1467 " break;" ) ) ) 1468 (for (C . L) *AsmOpcodes 1469 (prinl 1470 (unless *FPic " ") 1471 " case " 1472 (+ *OpOffs C) 1473 ": // " 1474 (fmtInstruction (car L)) ) 1475 (for S (cdr L) 1476 (prinl 1477 (unless *FPic " ") 1478 " " 1479 S ) ) 1480 (prinl 1481 (unless *FPic " ") 1482 " break;" ) ) 1483 (prinl 1484 (unless *FPic " ") 1485 " default:" ) 1486 (if *FPic 1487 (mapc prinl 1488 (quote 1489 " if (NextLib)" 1490 " (*NextLib)();" ) ) 1491 (mapc prinl 1492 (quote 1493 " if (FirstLib)" 1494 " (*FirstLib)();" ) ) ) 1495 (for S 1496 (quote 1497 " else {" 1498 " fprintf(stderr, \"Bad instruction\\n\");" 1499 " exit(112);" 1500 " }" 1501 " }" 1502 ~(as (and *Dbg (not *FPic)) 1503 " fprintf(stderr, \" %llX %llX %llX %llX %llX %llX %d%d%d %llX %llX\\n\"," 1504 " A.n, C.n, E.n, X.n, Y.n, Z.n," 1505 " !Result, (int64_t)Result<0, Carry," 1506 " L.n, S.n );" ) ) 1507 (prinl 1508 (unless *FPic " ") 1509 S ) ) 1510 (unless *FPic (prinl " }")) 1511 (prinl "}") 1512 (when *FPic 1513 (mapc prinl 1514 (quote 1515 NIL 1516 "static void __attribute__((constructor)) linkOpcodes(void) {" 1517 " NextLib = FirstLib, FirstLib = opcodes;" 1518 "}" ) ) ) 1519 (unless *FPic 1520 (mapc prinl 1521 (quote 1522 NIL 1523 "int main(int ac, char *av[]) {" 1524 " int i;" 1525 NIL 1526 " Y.p = malloc((ac + 1) * sizeof(op));" 1527 " i = 0; do" 1528 " ((ptr)Y.p)[i].n = (uint64_t)(unsigned long)av[i];" 1529 " while (++i < ac);" 1530 " ((ptr)Y.p)[i].n = 0;" 1531 " X.p = ((ptr)Y.p)->p, Y.p += 8;" 1532 " Z.p = Y.p + (ac - 2) * sizeof(op);" 1533 " if ((Stack = malloc(STACK)) == NULL)" 1534 " emuStkErr();" 1535 " S.p = Stack + STACK;" ) ) 1536 (prinl (pack " run(" (absCode "main") ");")) 1537 (prinl " return 0;") 1538 (prinl "}") ) 1539 (if *FPic 1540 (out "+emu.symtab" 1541 (println (mapcar car *AsmOpcodes)) ) 1542 (out "emu.symtab" 1543 (println 1544 (mapcar '((D) (cons (car D) (cadr D))) 1545 *AsmData ) ) 1546 (println 1547 (make 1548 (for (I . X) *AsmCode 1549 (for Lbl (cdr X) 1550 (unless (pre? "." Lbl) 1551 (link (cons Lbl (dec I))) ) ) ) ) ) 1552 (println (mapcar car *AsmOpcodes)) ) ) ) 1553 1554 # vi:et:ts=3:sw=3