asm.l (17971B)
1 # 05jan13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *LittleEndian *AlignedCode *Registers optimize 5 6 # *FPic *Section *Label *Tags *Map *Program *Statement 7 # *Instructions *IfStack *DoStack 8 # "*Mode" "*Modes" 9 10 (de *Transfers 11 call 12 jmp 13 jz jeq 14 jnz jne 15 js 16 jns 17 jsz 18 jnsz 19 jc jlt 20 jnc jge 21 jcz jle 22 jncz jgt ) 23 24 (de *Conditions 25 (T jmp . jmp) 26 (z jz . jnz) 27 (nz jnz . jz) 28 (s js . jns) 29 (ns jns . js) 30 (sz jsz . jnsz) 31 (nsz jnsz . jsz) 32 (c jc . jnc) 33 (nc jnc . jc) 34 (cz jcz . jncz) 35 (ncz jncz . jcz) 36 (eq jz . jnz) 37 (ne jnz . jz) 38 (lt jc . jnc) 39 (le jcz . jncz) 40 (gt jncz . jcz) 41 (ge jnc . jc) ) 42 43 (de build ("File" "Map" . "Prg") 44 (off *Section *Tags *Map *IfStack *DoStack) 45 (out "File" 46 (prinl "/* " (datSym (date)) " */") 47 (prolog "File") 48 (run "Prg") 49 (epilog "File") ) 50 (when "Map" 51 (out "tags" 52 (for Lst 53 (group # (file (line . sym) (line . sym) ..) 54 (mapcar 55 '((This) 56 (cons 57 (pack (: src 1) (: src 2)) 58 (: src -2) 59 This ) ) 60 (idx '*Tags) ) ) 61 (let Tags 62 (in (car Lst) 63 (let (Line 1 Ofs 0) 64 (mapcar 65 '((X) 66 (do (- (car X) Line) 67 (inc 'Ofs (inc (size (line T)))) ) 68 (pack 69 `(pack "^J" (char 127)) 70 (cdr X) 71 (char 1) 72 (setq Line (car X)) 73 "," 74 Ofs ) ) 75 (sort (cdr Lst)) ) ) ) 76 (prinl "^L^J" (car Lst) "," (sum size Tags) Tags) ) ) ) 77 (out "Map" 78 (for Sym (idx '*Map) 79 (and 80 (sym? (val Sym)) 81 (; Sym 0 tag) 82 (prinl Sym " (" (cdr @) " . \"@src64/" (car @) "\")") ) ) ) ) ) 83 84 (de asm Args 85 (def (car Args) 'asm (cdr Args)) ) 86 87 (de idxTags (Lbl Src) 88 (when Src 89 (idx '*Tags (def Lbl 'src @) T) ) ) 90 91 # Sections 92 (de section (Fun @Sym) 93 (def Fun 94 (curry (@Sym) (Lbl Align) 95 (newSection '@Sym) 96 (and Align (alignSection @)) 97 (when Lbl 98 (and (reg Lbl) (quit "Register" Lbl)) 99 (let Src (file) 100 (idxTags Lbl Src) 101 (def Lbl 'tag (cdr Src)) ) 102 (label (setq *Label Lbl) T) ) 103 (setq *Program 104 (make 105 (while (and (skip "#") (<> "(" (peek))) 106 (let Atom (read) 107 (cond 108 ((== ': Atom) # Label 109 (let Lbl (read) 110 (idxTags Lbl (file)) 111 (link (cons Atom Lbl)) ) ) 112 ((== '? Atom) # Conditional 113 (unless (eval (read)) 114 (while (and (skip "#") (n== '= (read)))) ) ) 115 ((== '= Atom)) # Conditional end 116 ((num? Atom) 117 (link (cons ': (pack *Label "_" Atom))) ) 118 ((lup *FlowControl Atom) 119 ((; Atom asm) (eval (cadr @))) ) 120 ((lup *Instructions Atom) 121 (link (cons Atom (mapcar eval (cdr @)))) ) 122 (T (quit "Bad instruction" Atom)) ) ) ) ) ) 123 (when (or *IfStack *DoStack) 124 (quit "Unbalanced flow") ) 125 (cleanUp) 126 (setq *Program 127 (make 128 (for (L *Program L) 129 (ifn (optimize L) 130 (link (pop 'L)) 131 (setq L (nth L (inc (car @)))) 132 (chain (cdr @)) ) ) ) ) 133 (for *Statement *Program 134 (if (== ': (car *Statement)) 135 (label (cdr *Statement)) 136 (apply (; (car *Statement) asm) (cdr *Statement)) ) ) ) ) ) 137 138 # (data 'lbl) 139 # (data 'lbl 0) 140 (section 'data 'data) 141 142 # (code 'lbl) 143 # (code 'lbl 0) 144 # (code 'lbl 2) 145 (section 'code 'text) 146 147 (de cleanUp () 148 (use (L1 L2) 149 (while # Remove duplicate labels 150 (seek 151 '((L) 152 (and 153 (== ': (caar L)) 154 (== ': (caadr L)) 155 (cond 156 ((= `(char ".") (char (setq L1 (cdar L)))) 157 (setq L2 (cdadr L)) ) 158 ((= `(char ".") (char (setq L1 (cdadr L)))) 159 (setq L2 (cdar L)) ) ) ) ) 160 *Program ) 161 (setq *Program 162 (mapcan 163 '((L) 164 (cond 165 ((<> L1 ((if (atom (cdr L)) cdr cadr) L)) 166 (cons L) ) 167 ((memq (car L) *Transfers) 168 (cons (list (car L) L2)) ) ) ) 169 *Program ) ) ) 170 (while # Remove jmp-only labels 171 (seek 172 '((L) 173 (and 174 (== ': (car (setq L1 (car L)))) 175 (= `(char ".") (char (cdr L1))) 176 (== 'jmp (car (setq L2 (cadr L)))) ) ) 177 *Program ) 178 (setq *Program 179 (mapcan 180 '((L) 181 (unless (== L L1) 182 (cons 183 (if 184 (and 185 (memq (car L) *Transfers) 186 (= (cdr L1) (cadr L)) ) 187 (list (car L) (cadr L2)) 188 L ) ) ) ) 189 *Program ) ) ) ) 190 (setq *Program # Remove unreachable statements 191 (make 192 (while *Program 193 (when (memq (car (link (pop '*Program))) '(jmp ret eval/ret)) 194 (while (and *Program (n== ': (caar *Program))) 195 (pop '*Program) ) ) ) ) ) 196 (setq *Program # Remove zero jumps 197 (make 198 (while *Program 199 (let P (pop '*Program) 200 (unless 201 (and 202 (memq (car P) (cdr *Transfers)) 203 (== ': (caar *Program)) 204 (= (cadr P) (cdar *Program)) ) 205 (link P) ) ) ) ) ) 206 (setq *Program # Toggle inverted jumps 207 (make 208 (while *Program 209 (let P (pop '*Program) 210 (ifn 211 (and 212 (memq (car P) (cddr *Transfers)) 213 (== 'jmp (caar *Program)) 214 (== ': (caadr *Program)) 215 (= (cadr P) (cadr (cadr *Program))) ) 216 (link P) 217 (link 218 (list 219 (cddr 220 (find 221 '((C) (== (car P) (cadr C))) 222 (cdr *Conditions) ) ) 223 (cadr (pop '*Program)) ) ) ) ) ) ) ) ) 224 225 # Registers 226 (de reg (X) 227 (cdr (asoq X *Registers)) ) 228 229 # Operand evaluation 230 (de operand (X) 231 (cond 232 ((num? X) X) 233 ((sym? X) 234 (cond 235 ((asoq X *Registers) X) 236 ((; X equ) @) 237 (T X) ) ) 238 ((asoq (car X) *Registers) 239 (cons (car X) (operand (cadr X))) ) 240 ((memq (car X) '(+ - * */ / % >> & | %% pack short char hex oct)) 241 (apply (car X) (mapcar operand (cdr X))) ) 242 (T (cons (car X) (operand (cadr X)))) ) ) 243 244 # Constants 245 (de %% (N) 246 (>> -3 (>> 3 (+ N 7))) ) 247 248 (de short (N) 249 (| 2 (>> -4 N)) ) 250 251 (de equ Args 252 (idxTags (car Args) (file)) 253 (let Val (run (cdr Args) 1) 254 (def (car Args) 'equ Val) 255 (def (car Args) Val) ) ) 256 257 258 # Source/Destination addressing mode: 259 # 0 -> Immediate 260 # NIL -> Register 261 # T -> Direct 262 # (..) -> Combined 263 (de "source" (X F) 264 (setq X (operand X)) 265 (cond 266 ((num? X) # Immediate 267 (zero "*Mode") 268 (pack (and F "~") X) ) 269 ((reg X) (off "*Mode") @) # Register 270 ((atom X) (on "*Mode") X) # Direct 271 ((or (num? (cdr X)) (; (cdr X) equ)) 272 (prog1 (cons ("source" (car X) F) @) 273 (setq "*Mode" (cons "*Mode" 0)) ) ) 274 ((cdr X) 275 (and (reg (cdr X)) (quit "Bad source" X)) 276 (prog1 (cons ("source" (car X) F) @) 277 (setq "*Mode" (cons "*Mode" T)) ) ) 278 (T 279 (prog1 (cons ("source" (car X) F)) 280 (setq "*Mode" (cons "*Mode")) ) ) ) ) 281 282 (de source (F) 283 ("source" (read) F) ) 284 285 (de sources () 286 (off "*Modes") 287 (let Arg (read) 288 (if (lst? Arg) 289 (mapcar 290 '((X) 291 (prog1 ("source" X) 292 (queue '"*Modes" "*Mode") ) ) 293 Arg ) 294 ("source" Arg) ) ) ) 295 296 (de "destination" (X F) 297 (setq X (operand X)) 298 (cond 299 ((num? X) (quit "Bad destination" X)) # Immediate 300 ((reg X) (off "*Mode") @) # Register 301 ((atom X) # Direct 302 (or F (quit "Bad destination" X)) 303 (on "*Mode") 304 X ) 305 ((or (num? (cdr X)) (; (cdr X) equ)) 306 (prog1 (cons ("destination" (car X) T) @) 307 (setq "*Mode" (cons "*Mode" 0)) ) ) 308 ((cdr X) 309 (and (reg (cdr X)) (quit "Bad destination" X)) 310 (prog1 (cons ("destination" (car X) T) (cdr X)) 311 (setq "*Mode" (cons "*Mode" T)) ) ) 312 (T 313 (prog1 (cons ("destination" (car X) T)) 314 (setq "*Mode" (cons "*Mode")) ) ) ) ) 315 316 (de destination () 317 ("destination" (read)) ) 318 319 (de destinations () 320 (off "*Modes") 321 (mapcar 322 '((X) 323 (prog1 ("destination" X) 324 (queue '"*Modes" "*Mode") ) ) 325 (read) ) ) 326 327 328 # Target addressing mode: 329 # NIL -> Absolute 330 # 0 -> Indexed 331 # (0) -> SUBR 332 # T -> Indirect 333 (de address () 334 (let X (read) 335 (off "*Mode") 336 (cond 337 ((num? X) (pack *Label "_" X)) # Label 338 ((reg X) (quit "Bad address" X)) # Register 339 ((atom X) X) # Absolute 340 ((and (=T (cadr X)) (reg (car X))) # SUBR 341 (setq "*Mode" (0)) 342 @ ) 343 ((cdr X) (quit "Bad address" X)) 344 ((reg (car X)) (zero "*Mode") @) # Register indirect 345 (T (on "*Mode") (car X)) ) ) ) # Indirect 346 347 348 # Flow control 349 (balance '*FlowControl 350 (quote 351 (break (read)) 352 (continue (read)) 353 (do) 354 (else) 355 (end) 356 (if (read)) 357 (loop) 358 (until (read)) 359 (while (read)) ) ) 360 361 (de flowCondition (Sym Lbl Neg) 362 (if ((if Neg cddr cadr) (asoq Sym *Conditions)) 363 (link (list @ Lbl)) 364 (quit "Bad condition" Sym) ) ) 365 366 (de flowLabel () 367 (pack "." (inc (0))) ) 368 369 (asm if (Sym) 370 (flowCondition Sym (push '*IfStack (flowLabel)) T) ) 371 372 (asm else () 373 (let Lbl (car *IfStack) 374 (link 375 (list 'jmp (set *IfStack (flowLabel))) 376 (cons ': Lbl) ) ) ) 377 378 (asm end () 379 (link (cons ': (pop '*IfStack))) ) 380 381 (asm do () 382 (link (cons ': (push '*DoStack (flowLabel)))) ) 383 384 (asm while (Sym) 385 (flowCondition Sym 386 (if (pair (car *DoStack)) 387 (car @) 388 (push *DoStack (flowLabel)) ) 389 T ) ) 390 391 (asm until (Sym) 392 (let X (pop '*DoStack) 393 (flowCondition Sym (fin X) T) 394 (and (pair X) (link (cons ': (car X)))) ) ) 395 396 (asm break (Sym) 397 (flowCondition Sym 398 (if (pair (car *DoStack)) 399 (car @) 400 (push *DoStack (flowLabel)) ) ) ) 401 402 (asm continue (Sym) 403 (flowCondition Sym (fin (car *DoStack))) ) 404 405 (asm loop () 406 (let X (pop '*DoStack) 407 (link (list 'jmp (fin X))) 408 (and (pair X) (link (cons ': (car X)))) ) ) 409 410 411 # Instruction set 412 (balance '*Instructions 413 (quote 414 (add (destination) "*Mode" (source) "*Mode") 415 (addc (destination) "*Mode" (source) "*Mode") 416 (align (operand (read))) 417 (and (destination) "*Mode" (source) "*Mode") 418 (ascii (operand (read))) 419 (asciz (operand (read))) 420 (atom (source) "*Mode") 421 (begin) 422 (big (source) "*Mode") 423 (byte (operand (read))) 424 (bytes (mapcar operand (read))) 425 (cc (address) "*Mode" (sources) "*Modes") 426 (call (address) "*Mode") 427 (clrc) 428 (clrz) 429 (cmp (destination) "*Mode" (source) "*Mode") 430 (cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode") 431 (cnt (source) "*Mode") 432 (dec (destination) "*Mode") 433 (div (source) "*Mode") 434 (drop) 435 (eval) 436 (eval+) 437 (eval/ret) 438 (exec (reg (read))) 439 (fixnum) 440 (float) 441 (func) 442 (hx2 (read)) 443 (inc (destination) "*Mode") 444 (initCode) 445 (initData) 446 (initFun (file) (read) (read) (operand (read))) 447 (initLib) 448 (initMain) 449 (initSym (file) (read) (read) (operand (read))) 450 (jc (address) "*Mode") 451 (jcz (address) "*Mode") 452 (jeq (address) "*Mode") 453 (jge (address) "*Mode") 454 (jgt (address) "*Mode") 455 (jle (address) "*Mode") 456 (jlt (address) "*Mode") 457 (jmp (address) "*Mode") 458 (jnc (address) "*Mode") 459 (jncz (address) "*Mode") 460 (jne (address) "*Mode") 461 (jns (address) "*Mode") 462 (jnsz (address) "*Mode") 463 (jnz (address) "*Mode") 464 (js (address) "*Mode") 465 (jsz (address) "*Mode") 466 (jz (address) "*Mode") 467 (:: (file) (read)) 468 (ld (destination) "*Mode" (source) "*Mode") 469 (ld2 (source) "*Mode") 470 (ld4 (source) "*Mode") 471 (ldc (destination) "*Mode" (source) "*Mode") 472 (ldd) 473 (ldf) 474 (ldnc (destination) "*Mode" (source) "*Mode") 475 (ldnz (destination) "*Mode" (source) "*Mode") 476 (ldz (destination) "*Mode" (source) "*Mode") 477 (lea (destination) "*Mode" (source) "*Mode") 478 (link) 479 (load (destination) "*Mode" (destination) "*Mode" (source) "*Mode") 480 (memb (source) "*Mode" (source) "*Mode") 481 (movm (destination) "*Mode" (source) "*Mode" (source) "*Mode") 482 (movn (destination) "*Mode" (source) "*Mode" (source) "*Mode") 483 (mset (destination) "*Mode" (source) "*Mode") 484 (mul (source) "*Mode") 485 (neg (destination) "*Mode") 486 (nop) 487 (not (destination) "*Mode") 488 (nul (source) "*Mode") 489 (nul4) 490 (null (source) "*Mode") 491 (nulp (source) "*Mode") 492 (num (source) "*Mode") 493 (off (destination) "*Mode" (source T) "*Mode") 494 (or (destination) "*Mode" (source) "*Mode") 495 (pop (destination) "*Mode") 496 (prog (reg (read))) 497 (push (source) "*Mode") 498 (rcl (destination) "*Mode" (source) "*Mode") 499 (rcr (destination) "*Mode" (source) "*Mode") 500 (ret) 501 (return) 502 (rol (destination) "*Mode" (source) "*Mode") 503 (ror (destination) "*Mode" (source) "*Mode") 504 (save (source) "*Mode" (source) "*Mode" (destination) "*Mode") 505 (set (destination) "*Mode" (source) "*Mode") 506 (setc) 507 (setz) 508 (shl (destination) "*Mode" (source) "*Mode") 509 (shr (destination) "*Mode" (source) "*Mode") 510 (skip (operand (read))) 511 (slen (destination) "*Mode" (source) "*Mode") 512 (st2 (destination) "*Mode") 513 (st4 (destination) "*Mode") 514 (std) 515 (stf) 516 (sub (destination) "*Mode" (source) "*Mode") 517 (subc (destination) "*Mode" (source) "*Mode") 518 (sym (source) "*Mode") 519 (test (destination) "*Mode" (source) "*Mode") 520 (tuck (source) "*Mode") 521 (word (operand (read))) 522 (xchg (destination) "*Mode" (destination) "*Mode") 523 (xor (destination) "*Mode" (source) "*Mode") 524 (zxt) ) ) 525 526 527 # Directives 528 529 (asm :: (Src Lbl) 530 (idxTags Lbl Src) 531 (label Lbl T) ) 532 533 (asm initFun (Src Lbl Name Val) 534 (initSym Src Lbl Name Val (pack Val (and *AlignedCode "+2"))) ) 535 536 (asm initSym (Src Lbl Name Val) 537 (initSym Src Lbl Name Val Val) ) 538 539 (de initSym (Src Lbl Name Sym Val) 540 (and Lbl (idxTags Lbl Src)) 541 (idx '*Map (def Name Sym) T) 542 (setq Name 543 (let (N 2 Lst (chop Name) C) 544 (make 545 (while (nth Lst 8) 546 (let L (mapcar char (cut 8 'Lst)) 547 (unless *LittleEndian 548 (setq L (flip L)) ) 549 (chain L) ) ) 550 (let L 551 (make 552 (do 7 553 (setq C (char (pop 'Lst))) 554 (link (| N (>> -4 (& 15 C)))) 555 (setq N (& 15 (>> 4 C))) ) 556 (link N) ) 557 (unless *LittleEndian 558 (setq L (flip L)) ) 559 (chain L) ) ) ) ) 560 (if (nth Name 9) 561 ((; 'word asm) ".+20") 562 ((; 'bytes asm) Name) 563 (off Name) ) 564 (when Lbl 565 (label Lbl T) ) 566 ((; 'word asm) Val) 567 (while Name 568 ((; 'bytes asm) (cut 8 'Name)) ) ) 569 570 571 # Condition code optimizations 572 (de asmNoCC Args 573 (let Sym (intern (pack (car Args) "-")) 574 (put (car Args) 'noCC Sym) 575 (def Sym 'asm (cdr Args)) ) ) 576 577 (de useCC Lst 578 (for Sym Lst 579 (put Sym 'useCC T) ) ) 580 581 (de chgCC Lst 582 (for Sym Lst 583 (put Sym 'chgCC T) ) ) 584 585 (useCC 586 ldc ldnc ldz ldnz 587 addc subc rcl rcr 588 jz jeq jnz jne js jns jsz jnsz jc jlt jnc jge jcz jle jncz jgt ) 589 590 (chgCC 591 movn mset movm save load 592 add sub inc dec not neg and or xor off test shl shr rol ror 593 mul div zxt setz clrz 594 cmp cmpn slen memb null nul4 nul cnt big num sym atom 595 call cc return 596 eval eval+ eval/ret exec prog ) 597 598 (de noCC (Lst) 599 (with (caar Lst) 600 (and 601 (: noCC) 602 (loop 603 (NIL (setq Lst (cdr Lst))) 604 (T (; Lst 1 1 useCC)) 605 (T (; Lst 1 1 chgCC) T) 606 (T (= '(push T NIL) (car Lst))) 607 (T (= '(pop T NIL) (car Lst)) T) 608 (T (== 'ret (caar Lst)) 609 (use (@A @B @Z) 610 (not (match '(@A "_" @B "F" @Z) (chop *Label))) ) ) 611 (T 612 (and 613 (== 'jmp (caar Lst)) 614 (not (setq Lst (member (cons ': (cadar Lst)) *Program))) ) ) ) 615 (: noCC) ) ) ) 616 617 618 # Warning message 619 (de warn (Msg) 620 (out 2 621 (printsp *Label *Statement) 622 (prinl Msg) ) ) 623 624 # vi:et:ts=3:sw=3