asm.scm

   1 ;;; File: "asm.scm"
   2 ;;;
   3 ;;; This module implements the generic assembler.
   4
   5 ;(##declare (standard-bindings) (fixnum) (block))
   6
   7 (define compiler-internal-error error)
   8
   9 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
  10 ;; starts a new empty code stream at address "start-pos".  It must be
  11 ;; called every time a new code stream is to be built.  The argument
  12 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
  13 ;; bit values.  After a call to "asm-begin!" the code stream is built
  14 ;; by calling the following procedures:
  15 ;;
  16 ;;  asm-8            to add an 8 bit integer to the code stream
  17 ;;  asm-16           to add a 16 bit integer to the code stream
  18 ;;  asm-32           to add a 32 bit integer to the code stream
  19 ;;  asm-64           to add a 64 bit integer to the code stream
  20 ;;  asm-float64      to add a 64 bit IEEE float to the code stream
  21 ;;  asm-string       to add a null terminated string to the code stream
  22 ;;  asm-label        to set a label to the current position in the code stream
  23 ;;  asm-align        to add enough zero bytes to force alignment
  24 ;;  asm-origin       to add enough zero bytes to move to a particular address
  25 ;;  asm-at-assembly  to defer code production to assembly time
  26 ;;  asm-listing      to add textual information to the listing
  27
  28 (define (asm-begin! start-pos big-endian?)
  29   (set! asm-start-pos start-pos)
  30   (set! asm-big-endian? big-endian?)
  31   (set! asm-code-stream (asm-make-stream))
  32   #f)
  33
  34 ;; (asm-end!) must be called to finalize the assembler.
  35
  36 (define (asm-end!)
  37   (set! asm-code-stream #f)
  38   #f)
  39
  40 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
  41
  42 (define (asm-8 n)
  43   (asm-code-extend (asm-bits-0-to-7 n)))
  44
  45 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
  46
  47 (define (asm-16 n)
  48   (if asm-big-endian?
  49     (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
  50     (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
  51
  52 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
  53
  54 (define (asm-32 n)
  55   (if asm-big-endian?
  56     (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
  57     (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
  58
  59 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
  60
  61 (define (asm-64 n)
  62   (if asm-big-endian?
  63     (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
  64     (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
  65
  66 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
  67
  68 (define (asm-float64 n)
  69   (asm-64 (asm-float->bits n)))
  70
  71 ;; (asm-string str) adds a null terminated string to the code stream.
  72
  73 (define (asm-string str)
  74   (let ((len (string-length str)))
  75     (let loop ((i 0))
  76       (if (< i len)
  77         (begin
  78           (asm-8 (char->integer (string-ref str i)))
  79           (loop (+ i 1)))
  80         (asm-8 0)))))
  81
  82 ;; (asm-make-label id) creates a new label object.  A label can
  83 ;; be queried with "asm-label-pos" to obtain the label's position
  84 ;; relative to the start of the code stream (i.e. "start-pos").
  85 ;; The argument "id" gives a name to the label (not necessarily
  86 ;; unique) and is only needed for debugging purposes.
  87
  88 (define (asm-make-label id #!optional (pos #f))
  89   (vector 'LABEL pos id))
  90
  91 ;; (asm-label label-obj) sets the label to the current position in the
  92 ;; code stream.
  93
  94 (define (asm-label label-obj)
  95   (if (vector-ref label-obj 1)
  96     (compiler-internal-error
  97       "asm-label, label multiply defined" (asm-label-id label-obj))
  98     (begin
  99       (vector-set! label-obj 1 0)
 100       (asm-code-extend label-obj))))
 101
 102 ;; (asm-label-id label-obj) returns the identifier of the label object.
 103
 104 (define (asm-label-id label-obj)
 105   (vector-ref label-obj 2))
 106
 107 ;; (asm-label-pos label-obj) returns the position of the label
 108 ;; relative to the start of the code stream (i.e. "start-pos").
 109 ;; This procedure can only be called at assembly time (i.e.
 110 ;; within the call to "asm-assemble") or after assembly time
 111 ;; for labels declared prior to assembly time with "asm-label".
 112 ;; A label declared at assembly time can only be queried after
 113 ;; assembly time.  Moreover, at assembly time the position of a
 114 ;; label may vary from one call to the next due to the actions
 115 ;; of the assembler.
 116
 117 (define (asm-label-pos label-obj)
 118   (let ((pos (vector-ref label-obj 1)))
 119     (if pos
 120       pos
 121       (compiler-internal-error
 122         "asm-label-pos, undefined label" (asm-label-id label-obj)))))
 123
 124 ;; (asm-align multiple offset) adds enough zero bytes to the code
 125 ;; stream to force alignment to the next address congruent to
 126 ;; "offset" modulo "multiple".
 127
 128 (define (asm-align multiple offset)
 129   (asm-at-assembly
 130     (lambda (self)
 131       (modulo (- multiple (- self offset)) multiple))
 132     (lambda (self)
 133       (let loop ((n (modulo (- multiple (- self offset)) multiple)))
 134         (if (> n 0)
 135           (begin
 136             (asm-8 0)
 137             (loop (- n 1))))))))
 138
 139 ;; (asm-origin address) adds enough zero bytes to the code stream to move
 140 ;; to the address "address".
 141
 142 (define (asm-origin address)
 143   (asm-at-assembly
 144     (lambda (self)
 145       (- address self))
 146     (lambda (self)
 147       (let ((len (- address self)))
 148         (if (< len 0)
 149           (compiler-internal-error "asm-origin, can't move back")
 150           (let loop ((n len))
 151             (if (> n 0)
 152               (begin
 153                 (asm-8 0)
 154                 (loop (- n 1))))))))))
 155
 156 ;; (asm-at-assembly . procs) makes it possible to defer code
 157 ;; production to assembly time.  A useful application is to generate
 158 ;; position dependent and span dependent code sequences.  This
 159 ;; procedure must be passed an even number of procedures.  All odd
 160 ;; indexed procedures (including the first procedure) are called "check"
 161 ;; procedures.  The even indexed procedures are the "production"
 162 ;; procedures which, when called, produce a particular code sequence.
 163 ;; A check procedure decides if, given the current state of assembly
 164 ;; (in particular the current positioning of the labels), the code
 165 ;; produced by the corresponding production procedure is valid.
 166 ;; If the code is not valid, the check procedure must return #f.
 167 ;; If the code is valid, the check procedure must return the length
 168 ;; of the code sequence in bytes.  The assembler will try each check
 169 ;; procedure in order until it finds one that does not return #f
 170 ;; (the last check procedure must never return #f).  For convenience,
 171 ;; the current position in the code sequence is passed as the single
 172 ;; argument of check and production procedures.
 173 ;;
 174 ;; Here is a sample call of "asm-at-assembly" to produce the
 175 ;; shortest branch instruction to branch to label "x" for a
 176 ;; hypothetical processor:
 177 ;;
 178 ;;  (asm-at-assembly
 179 ;;
 180 ;;    (lambda (self) ; first check procedure
 181 ;;      (let ((dist (- (asm-label-pos x) self)))
 182 ;;        (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
 183 ;;          2
 184 ;;          #f)))
 185 ;;
 186 ;;    (lambda (self) ; first production procedure
 187 ;;      (asm-8 #x34) ; branch opcode for 8 bit displacement
 188 ;;      (asm-8 (- (asm-label-pos x) self)))
 189 ;;
 190 ;;    (lambda (self) 5) ; second check procedure
 191 ;;
 192 ;;    (lambda (self) ; second production procedure
 193 ;;      (asm-8 #x35) ; branch opcode for 32 bit displacement
 194 ;;      (asm-32 (- (asm-label-pos x) self))))
 195
 196 (define (asm-at-assembly . procs)
 197   (asm-code-extend (vector 'DEFERRED procs)))
 198
 199 ;; (asm-listing text) adds text to the right side of the listing.
 200 ;; The atoms in "text" will be output using "display" (lists are
 201 ;; traversed recursively).  The listing is generated by calling
 202 ;; "asm-display-listing".
 203
 204 (define (asm-listing text)
 205   (asm-code-extend (vector 'LISTING text)))
 206
 207 ;; (asm-assemble) assembles the code stream.  After assembly, the
 208 ;; label objects will be set to their final position and the
 209 ;; alignment bytes and the deferred code will have been produced.  It
 210 ;; is possible to extend the code stream after assembly.  However, if
 211 ;; any of the procedures "asm-label", "asm-align", and
 212 ;; "asm-at-assembly" are called, the code stream will have to be
 213 ;; assembled once more.
 214
 215 (define (asm-assemble)
 216   (let ((fixup-lst (asm-pass1)))
 217
 218     (let loop1 ()
 219       (let loop2 ((lst fixup-lst)
 220                   (changed? #f)
 221                   (pos asm-start-pos))
 222         (if (null? lst)
 223           (if changed? (loop1))
 224           (let* ((fixup (car lst))
 225                  (pos (+ pos (car fixup)))
 226                  (curr (cdr fixup))
 227                  (x (car curr)))
 228             (if (eq? (vector-ref x 0) 'LABEL)
 229               ; LABEL
 230               (if (= (vector-ref x 1) pos)
 231                 (loop2 (cdr lst) changed? pos)
 232                 (begin
 233                   (vector-set! x 1 pos)
 234                   (loop2 (cdr lst) #t pos)))
 235               ; DEFERRED
 236               (let loop3 ()
 237                 (let ((n ((car (vector-ref x 1)) pos)))
 238                   (if n
 239                     (loop2 (cdr lst) changed? (+ pos n))
 240                     (begin
 241                       (vector-set! x 1 (cddr (vector-ref x 1)))
 242                       (loop3))))))))))
 243
 244     (let loop4 ((prev asm-code-stream)
 245                 (curr (cdr asm-code-stream))
 246                 (pos asm-start-pos))
 247       (if (null? curr)
 248         (set-car! asm-code-stream prev)
 249         (let ((x (car curr))
 250               (next (cdr curr)))
 251           (if (vector? x)
 252             (let ((kind (vector-ref x 0)))
 253               (cond ((eq? kind 'LABEL)
 254                      (let ((final-pos (vector-ref x 1)))
 255                        (if final-pos
 256                          (if (not (= pos final-pos))
 257                            (compiler-internal-error
 258                              "asm-assemble, inconsistency detected"))
 259                          (vector-set! x 1 pos))
 260                        (set-cdr! prev next)
 261                        (loop4 prev next pos)))
 262                     ((eq? kind 'DEFERRED)
 263                      (let ((temp asm-code-stream))
 264                        (set! asm-code-stream (asm-make-stream))
 265                        ((cadr (vector-ref x 1)) pos)
 266                        (let ((tail (car asm-code-stream)))
 267                          (set-cdr! tail next)
 268                          (let ((head (cdr asm-code-stream)))
 269                            (set-cdr! prev head)
 270                            (set! asm-code-stream temp)
 271                            (loop4 prev head pos)))))
 272                     (else
 273                      (loop4 curr next pos))))
 274             (loop4 curr next (+ pos 1))))))))
 275
 276 ;; (asm-display-listing port) produces a listing of the code stream
 277 ;; on the given output port.  The bytes generated are shown in
 278 ;; hexadecimal on the left side of the listing and the right side
 279 ;; of the listing contains the text inserted by "asm-listing".
 280
 281 (define (asm-display-listing port)
 282
 283   (define text-col 24)
 284   (define pos-width 6)
 285   (define byte-width 2)
 286
 287   (define (output text)
 288     (cond ((null? text))
 289           ((pair? text)
 290            (output (car text))
 291            (output (cdr text)))
 292           (else
 293            (display text port))))
 294
 295   (define (print-hex n)
 296     (display (string-ref "0123456789ABCDEF" n) port))
 297
 298   (define (print-byte n)
 299     (print-hex (quotient n 16))
 300     (print-hex (modulo n 16)))
 301
 302   (define (print-pos n)
 303     (if (< n 0)
 304       (display "      " port)
 305       (begin
 306         (print-byte (quotient n #x10000))
 307         (print-byte (modulo (quotient n #x100) #x100))
 308         (print-byte (modulo n #x100)))))
 309
 310   (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
 311     (if (null? lst)
 312       (if (> col 0)
 313         (newline port))
 314       (let ((x (car lst)))
 315         (if (vector? x)
 316           (let ((kind (vector-ref x 0)))
 317             (cond ((eq? kind 'LISTING)
 318                    (let loop2 ((col col))
 319                      (if (< col text-col)
 320                        (begin
 321                          (display (integer->char 9) port)
 322                          (loop2 (* 8 (+ (quotient col 8) 1))))))
 323                    (output (vector-ref x 1))
 324                    (newline port)
 325                    (loop1 (cdr lst) pos 0))
 326                   (else
 327                    (compiler-internal-error
 328                      "asm-display-listing, code stream not assembled"))))
 329           (if (or (= col 0) (>= col (- text-col byte-width)))
 330             (begin
 331               (if (not (= col 0)) (newline port))
 332               (print-pos pos)
 333               (display " " port)
 334               (print-byte x)
 335               (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
 336             (begin
 337               (print-byte x)
 338               (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
 339
 340 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
 341 ;; of bytes produced) on the named file.
 342
 343 (define (asm-write-code filename)
 344   (with-output-to-file filename
 345     (lambda ()
 346       (let loop ((lst (cdr asm-code-stream)))
 347         (if (not (null? lst))
 348           (let ((x (car lst)))
 349             (if (vector? x)
 350               (let ((kind (vector-ref x 0)))
 351                 (if (not (eq? kind 'LISTING))
 352                   (compiler-internal-error
 353                     "asm-write-code, code stream not assembled"))
 354                 (loop (cdr lst)))
 355               (begin
 356                 (write-char (integer->char x))
 357                 (loop (cdr lst))))))))))
 358
 359 (define (asm-write-hex-file filename)
 360   (with-output-to-file filename
 361     (lambda ()
 362
 363       (define (print-hex n)
 364         (display (string-ref "0123456789ABCDEF" n)))
 365
 366       (define (print-byte n)
 367         (print-hex (quotient n 16))
 368         (print-hex (modulo n 16)))
 369
 370       (define (print-line type addr bytes)
 371         (let ((n (length bytes))
 372               (addr-hi (quotient addr 256))
 373               (addr-lo (modulo addr 256)))
 374           (display ":")
 375           (print-byte n)
 376           (print-byte addr-hi)
 377           (print-byte addr-lo)
 378           (print-byte type)
 379           (for-each print-byte bytes)
 380           (let ((sum
 381                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
 382             (print-byte sum)
 383             (newline))))
 384
 385       (let loop ((lst (cdr asm-code-stream))
 386                  (pos asm-start-pos)
 387                  (rev-bytes '()))
 388         (if (not (null? lst))
 389           (let ((x (car lst)))
 390             (if (vector? x)
 391               (let ((kind (vector-ref x 0)))
 392                 (if (not (eq? kind 'LISTING))
 393                   (compiler-internal-error
 394                     "asm-write-hex-file, code stream not assembled"))
 395                 (loop (cdr lst)
 396                       pos
 397                       rev-bytes))
 398               (let ((new-pos
 399                      (+ pos 1))
 400                     (new-rev-bytes
 401                      (cons x
 402                            (if (= (modulo pos 16) 0)
 403                                (begin
 404                                  (print-line 0
 405                                              (- pos (length rev-bytes))
 406                                              (reverse rev-bytes))
 407                                  '())
 408                                rev-bytes))))
 409                 (loop (cdr lst)
 410                       new-pos
 411                       new-rev-bytes))))
 412           (begin
 413             (if (not (null? rev-bytes))
 414                 (print-line 0
 415                             (- pos (length rev-bytes))
 416                             (reverse rev-bytes)))
 417             (print-line 1 0 '())))))))
 418
 419 ;; Utilities.
 420
 421 (define asm-start-pos #f)   ; start position of the code stream
 422 (define asm-big-endian? #f) ; endianness to use
 423 (define asm-code-stream #f) ; current code stream
 424
 425 (define (asm-make-stream) ; create an empty stream
 426   (let ((x (cons '() '())))
 427     (set-car! x x)
 428     x))
 429
 430 (define (asm-code-extend item) ; add an item at the end of current code stream
 431   (let* ((stream asm-code-stream)
 432          (tail (car stream))
 433          (cell (cons item '())))
 434     (set-cdr! tail cell)
 435     (set-car! stream cell)))
 436
 437 (define (asm-pass1) ; construct fixup list and make first label assignment
 438   (let loop ((curr (cdr asm-code-stream))
 439              (fixup-lst '())
 440              (span 0)
 441              (pos asm-start-pos))
 442     (if (null? curr)
 443       (reverse fixup-lst)
 444       (let ((x (car curr)))
 445         (if (vector? x)
 446           (let ((kind (vector-ref x 0)))
 447             (cond ((eq? kind 'LABEL)
 448                    (vector-set! x 1 pos) ; first approximation of position
 449                    (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
 450                   ((eq? kind 'DEFERRED)
 451                    (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
 452                   (else
 453                    (loop (cdr curr) fixup-lst span pos))))
 454           (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
 455
 456 ;(##declare (generic))
 457
 458 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
 459   (modulo n #x100))
 460
 461 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
 462   (if (>= n 0)
 463     (quotient n #x100)
 464     (- (quotient (+ n 1) #x100) 1)))
 465
 466 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
 467   (if (>= n 0)
 468     (quotient n #x10000)
 469     (- (quotient (+ n 1) #x10000) 1)))
 470
 471 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
 472   (if (>= n 0)
 473     (quotient n #x100000000)
 474     (- (quotient (+ n 1) #x100000000) 1)))
 475
 476 ; The following procedures convert floating point numbers into their
 477 ; machine representation.  They perform bignum and flonum arithmetic.
 478
 479 (define (asm-float->inexact-exponential-format x)
 480
 481   (define (exp-form-pos x y i)
 482     (let ((i*2 (+ i i)))
 483       (let ((z (if (and (not (< asm-ieee-e-bias i*2))
 484                         (not (< x y)))
 485                  (exp-form-pos x (* y y) i*2)
 486                  (cons x 0))))
 487         (let ((a (car z)) (b (cdr z)))
 488           (let ((i+b (+ i b)))
 489             (if (and (not (< asm-ieee-e-bias i+b))
 490                      (not (< a y)))
 491               (begin
 492                 (set-car! z (/ a y))
 493                 (set-cdr! z i+b)))
 494             z)))))
 495
 496   (define (exp-form-neg x y i)
 497     (let ((i*2 (+ i i)))
 498       (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
 499                         (< x y))
 500                  (exp-form-neg x (* y y) i*2)
 501                  (cons x 0))))
 502         (let ((a (car z)) (b (cdr z)))
 503           (let ((i+b (+ i b)))
 504             (if (and (< i+b asm-ieee-e-bias-minus-1)
 505                      (< a y))
 506               (begin
 507                 (set-car! z (/ a y))
 508                 (set-cdr! z i+b)))
 509             z)))))
 510
 511   (define (exp-form x)
 512     (if (< x asm-inexact-+1)
 513       (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
 514         (set-car! z (* asm-inexact-+2 (car z)))
 515         (set-cdr! z (- -1 (cdr z)))
 516         z)
 517       (exp-form-pos x asm-inexact-+2 1)))
 518
 519   (if (negative? x)
 520     (let ((z (exp-form (- asm-inexact-0 x))))
 521       (set-car! z (- asm-inexact-0 (car z)))
 522       z)
 523     (exp-form x)))
 524
 525 (define (asm-float->exact-exponential-format x)
 526   (let ((z (asm-float->inexact-exponential-format x)))
 527     (let ((y (car z)))
 528       (cond ((not (< y asm-inexact-+2))
 529              (set-car! z asm-ieee-+m-min)
 530              (set-cdr! z asm-ieee-e-bias-plus-1))
 531             ((not (< asm-inexact--2 y))
 532              (set-car! z asm-ieee--m-min)
 533              (set-cdr! z asm-ieee-e-bias-plus-1))
 534             (else
 535              (set-car! z
 536                (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
 537       (set-cdr! z (- (cdr z) asm-ieee-m-bits))
 538       z)))
 539
 540 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
 541
 542   (define (bits a b)
 543     (if (< a asm-ieee-+m-min)
 544       a
 545       (+ (- a asm-ieee-+m-min)
 546          (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
 547             asm-ieee-+m-min))))
 548
 549   (let ((z (asm-float->exact-exponential-format x)))
 550     (let ((a (car z)) (b (cdr z)))
 551       (if (negative? a)
 552         (+ asm-ieee-sign-bit (bits (- 0 a) b))
 553         (bits a b)))))
 554
 555 ; Parameters for ANSI-IEEE Std 754-1985 representation of
 556 ; doubles (i.e. 64 bit floating point numbers):
 557
 558 (define asm-ieee-m-bits 52)
 559 (define asm-ieee-e-bits 11)
 560 (define asm-ieee-+m-min 4503599627370496)    ; (expt 2 asm-ieee-m-bits)
 561 (define asm-ieee--m-min -4503599627370496)   ; (- asm-ieee-+m-min)
 562 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
 563
 564 (define asm-ieee-e-bias         1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
 565 (define asm-ieee-e-bias-plus-1  1024) ; (+ asm-ieee-e-bias 1)
 566 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
 567
 568 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
 569 (define asm-inexact-+2    (exact->inexact 2))
 570 (define asm-inexact--2    (exact->inexact -2))
 571 (define asm-inexact-+1    (exact->inexact 1))
 572 (define asm-inexact-+1/2  (exact->inexact (/ 1 2)))
 573 (define asm-inexact-0     (exact->inexact 0))