gsc/_asm.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_asm.scm"
   4
   5 ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 ;;; This module implements the generic assembler.
  10
  11 (namespace ("_asm#") ("" include))
  12 (include "~~lib/gambit#.scm")
  13
  14 (include "_asm#.scm")
  15
  16 ;; TODO: remove this import
  17 (namespace ("c#" compiler-internal-error)) ;; import
  18
  19 (asm-implement)
  20
  21 ;;;============================================================================
  22
  23 ;; (asm-make-code-block start-pos endianness) starts a new empty code
  24 ;; block at address start-pos and returns it.  The parameter
  25 ;; endianness is a symbol (be or le) which indicates the byte ordering
  26 ;; to use for 16, 32 and 64 bit values.  After a call to
  27 ;; asm-make-code-block the code block is built by calling the
  28 ;; following procedures:
  29 ;;
  30 ;;  asm-8            adds an 8 bit integer to the code block
  31 ;;  asm-16-be        adds a 16 bit big-endian integer to the code block
  32 ;;  asm-16-le        adds a 16 bit little-endian integer to the code block
  33 ;;  asm-16           like asm-16-be or asm-16-le depending on endianness
  34 ;;  asm-32-be        adds a 32 bit big-endian integer to the code block
  35 ;;  asm-32-le        adds a 32 bit little-endian integer to the code block
  36 ;;  asm-32           like asm-32-be or asm-32-le depending on endianness
  37 ;;  asm-64-be        adds a 64 bit big-endian integer to the code block
  38 ;;  asm-64-le        adds a 64 bit little-endian integer to the code block
  39 ;;  asm-64           like asm-64-be or asm-64-le depending on endianness
  40 ;;  asm-int          adds an 8/16/32/64 bit int to the code block
  41 ;;  asm-int-be       adds an 8/16/32/64 bit big-endian int to the code block
  42 ;;  asm-int-le       adds an 8/16/32/64 bit little-endian int to the code block
  43 ;;  asm-f32          adds a 32 bit IEEE float to the code block
  44 ;;  asm-f64          adds a 64 bit IEEE float to the code block
  45 ;;  asm-UTF-8-string adds a null terminated UTF-8 string to the code block
  46 ;;  asm-label        sets a label to the current position in the code block
  47 ;;  asm-align        adds enough padding bytes to force alignment
  48 ;;  asm-origin       adds enough padding bytes to move to a particular address
  49 ;;  asm-at-assembly  defers code production to assembly time
  50 ;;  asm-listing      adds textual information to the listing
  51
  52 (define (asm-make-code-block start-pos endianness)
  53   (asm-init-code-block (make-vector (asm-code-block-size) 'code-block)
  54                        start-pos
  55                        endianness))
  56
  57 (define (asm-init-code-block cb start-pos endianness)
  58   (asm-code-block-start-pos-set!  cb start-pos)
  59   (asm-code-block-endianness-set! cb endianness)
  60   (asm-code-block-stream-set!     cb (asm-make-stream))
  61   cb)
  62
  63 (define (asm-copy-code-block cb)
  64   (let ((copy (make-vector (asm-code-block-size) 'code-block)))
  65     (asm-code-block-start-pos-set!  copy (asm-code-block-start-pos  cb))
  66     (asm-code-block-endianness-set! copy (asm-code-block-endianness cb))
  67     (asm-code-block-stream-set!     copy (asm-code-block-stream     cb))
  68     copy))
  69
  70 ;; (asm-8 cb n) adds the 8 bit signed or unsigned integer n to the
  71 ;; code block.
  72
  73 (define (asm-8 cb n)
  74   (asm-code-extend cb (asm-bits-0-to-7 n)))
  75
  76 ;; (asm-16 cb n) adds the 16 bit signed or unsigned integer n to the
  77 ;; code block.
  78
  79 (define (asm-16 cb n)
  80   (case (asm-code-block-endianness cb)
  81     ((be)
  82      (asm-16-be cb n))
  83     (else ;; le
  84       (asm-16-le cb n))))
  85
  86 (define (asm-16-be cb n)
  87   (asm-8 cb (asm-bits-8-and-up n))
  88   (asm-8 cb n))
  89
  90 (define (asm-16-le cb n)
  91   (asm-8 cb n)
  92   (asm-8 cb (asm-bits-8-and-up n)))
  93
  94 ;; (asm-32 cb n) adds the 32 bit signed or unsigned integer n to the
  95 ;; code block.
  96
  97 (define (asm-32 cb n)
  98   (case (asm-code-block-endianness cb)
  99     ((be)
 100      (asm-32-be cb n))
 101     (else ;; le
 102      (asm-32-le cb n))))
 103
 104 (define (asm-32-be cb n)
 105   (asm-16-be cb (asm-bits-16-and-up n))
 106   (asm-16-be cb n))
 107
 108 (define (asm-32-le cb n)
 109   (asm-16-le cb n)
 110   (asm-16-le cb (asm-bits-16-and-up n)))
 111
 112 ;; (asm-64 cb n) adds the 64 bit signed or unsigned integer n to the
 113 ;; code block.
 114
 115 (define (asm-64 cb n)
 116   (case (asm-code-block-endianness cb)
 117     ((be)
 118      (asm-64-be cb n))
 119     (else ;; le
 120      (asm-64-le cb n))))
 121
 122 (define (asm-64-be cb n)
 123   (asm-32-be cb (asm-bits-32-and-up n))
 124   (asm-32-be cb n))
 125
 126 (define (asm-64-le cb n)
 127   (asm-32-le cb n)
 128   (asm-32-le cb (asm-bits-32-and-up n)))
 129
 130 ;; (asm-int cb n width) adds the signed or unsigned integer n of width
 131 ;; bits to the code block and returns the signed integer.
 132
 133 (define (asm-int cb n width)
 134   (case (asm-code-block-endianness cb)
 135     ((be)
 136      (asm-int-be cb n width))
 137     (else ;; le
 138      (asm-int-le cb n width))))
 139
 140 (define (asm-int-be cb n width)
 141   (cond ((fx= width 8)
 142          (let ((x (asm-signed-lo8 n)))
 143            (asm-8 cb x)
 144            x))
 145         ((fx= width 16)
 146          (let ((x (asm-signed-lo16 n)))
 147            (asm-16-be cb x)
 148            x))
 149         ((fx= width 32)
 150          (let ((x (asm-signed-lo32 n)))
 151            (asm-32-be cb x)
 152            x))
 153         (else
 154          (let ((x (asm-signed-lo64 n)))
 155            (asm-64-be cb x)
 156            x))))
 157
 158 (define (asm-int-le cb n width)
 159   (cond ((fx= width 8)
 160          (let ((x (asm-signed-lo8 n)))
 161            (asm-8 cb x)
 162            x))
 163         ((fx= width 16)
 164          (let ((x (asm-signed-lo16 n)))
 165            (asm-16-le cb x)
 166            x))
 167         ((fx= width 32)
 168          (let ((x (asm-signed-lo32 n)))
 169            (asm-32-le cb x)
 170            x))
 171         (else
 172          (let ((x (asm-signed-lo64 n)))
 173            (asm-64-le cb x)
 174            x))))
 175
 176 ;; (asm-f32 cb n) adds the 32 bit IEEE floating point number n to the
 177 ;; code block.
 178
 179 (define (asm-f32 cb n)
 180   (asm-32 cb (asm-float->bits n #f)))
 181
 182 ;; (asm-f64 cb n) adds the 64 bit IEEE floating point number n to the
 183 ;; code block.
 184
 185 (define (asm-f64 cb n)
 186   (asm-64 cb (asm-float->bits n #t)))
 187
 188 ;; (asm-UTF-8-string cb str) adds the null terminated UTF-8 string str
 189 ;; to the code block.
 190
 191 (define (asm-UTF-8-string cb str)
 192   (let* ((u8vect
 193           (with-output-to-u8vector
 194            '(char-encoding: UTF-8)
 195            (lambda ()
 196              (display str))))
 197          (len
 198           (u8vector-length u8vect)))
 199     (let loop ((i 0))
 200       (if (fx< i len)
 201           (begin
 202             (asm-8 cb (u8vector-ref u8vect i))
 203             (loop (fx+ i 1)))
 204           (asm-8 cb 0)))))
 205
 206 ;; (asm-make-label cb id) creates a new label object.  A label can be
 207 ;; queried with asm-label-pos to obtain the label's position.  The
 208 ;; argument id gives a name (not necessarily unique) to the label and
 209 ;; is only needed for debugging purposes.
 210
 211 (define (asm-make-label cb id #!optional (pos #f))
 212   (vector 'label
 213           pos
 214           id))
 215
 216 ;; (asm-label? x) tests if x is a label object.
 217
 218 (define (asm-label? x)
 219   (and (vector? x)
 220        (fx= (vector-length x) 3)
 221        (eq? (vector-ref x 0) 'label)))
 222
 223 ;; (asm-label cb label-obj) sets the label to the current position in
 224 ;; the code block.
 225
 226 (define (asm-label cb label-obj)
 227   (if (vector-ref label-obj 1)
 228       (compiler-internal-error
 229        "asm-label, label multiply defined"
 230        (asm-label-id label-obj))
 231       (begin
 232         (vector-set! label-obj 1 0)
 233         (asm-code-extend cb label-obj))))
 234
 235 ;; (asm-label-id label-obj) returns the identifier of the label object.
 236
 237 (define (asm-label-id label-obj)
 238   (vector-ref label-obj 2))
 239
 240 (define (asm-label-name label-obj)
 241   (let ((id (asm-label-id label-obj)))
 242     (cond ((string? id) id)
 243           ((symbol? id) (symbol->string id))
 244           ((number? id) (string-append "_" (number->string id)))
 245           (else
 246            (compiler-internal-error
 247             "asm-label-name, this type of label id is not supported" id)))))
 248
 249 ;; (asm-label-pos label-obj) returns the position of the label
 250 ;; relative to the start of the code block (i.e. start-pos).
 251 ;; This procedure can only be called at assembly time (i.e.
 252 ;; within the call to asm-assemble) or after assembly time
 253 ;; for labels declared prior to assembly time with asm-label.
 254 ;; A label declared at assembly time can only be queried after
 255 ;; assembly time.  Moreover, at assembly time the position of a
 256 ;; label may vary from one call to the next due to the actions
 257 ;; of the assembler.
 258
 259 (define (asm-label-pos label-obj)
 260   (let ((pos (vector-ref label-obj 1)))
 261     (if pos
 262         pos
 263         (compiler-internal-error
 264          "asm-label-pos, undefined label"
 265          (asm-label-id label-obj)))))
 266
 267 ;; (asm-align cb multiple offset fill) adds enough fill bytes to the
 268 ;; code block to force alignment to the next address congruent to
 269 ;; offset modulo multiple.
 270
 271 (define (asm-align cb multiple #!optional (offset 0) (fill 0))
 272   (asm-at-assembly
 273    cb
 274    (lambda (cb self)
 275      (fxmodulo (fx- multiple (fx- self offset)) multiple))
 276    (lambda (cb self)
 277      (let ((n (fxmodulo (fx- multiple (fx- self offset)) multiple)))
 278        (let loop ((i n))
 279          (if (fx> i 0)
 280              (begin
 281                (asm-8 cb fill)
 282                (loop (fx- i 1)))))))))
 283
 284 ;; (asm-origin cb address fill) adds enough fill bytes to the code
 285 ;; block to move to the given address.
 286
 287 (define (asm-origin cb address #!optional (fill 0))
 288   (asm-at-assembly
 289    cb
 290    (lambda (self)
 291      (fx- address self))
 292    (lambda (self)
 293      (let ((len (fx- address self)))
 294        (if (fx< len 0)
 295            (compiler-internal-error "asm-origin, can't move back")
 296            (let loop ((n len))
 297              (if (fx> n 0)
 298                  (begin
 299                    (asm-8 cb fill)
 300                    (loop (fx- n 1))))))))))
 301
 302 ;; (asm-at-assembly cb . procs) makes it possible to defer code
 303 ;; production to assembly time.  A useful application is to generate
 304 ;; position dependent and span dependent code sequences.  This
 305 ;; procedure must be passed an even number of procedures.  All odd
 306 ;; indexed procedures (including the first procedure) are called
 307 ;; "check" procedures.  The even indexed procedures are the
 308 ;; "production" procedures which, when called, produce a particular
 309 ;; code sequence.  A check procedure decides if, given the current
 310 ;; state of assembly (in particular the current positioning of the
 311 ;; labels), the code produced by the corresponding production
 312 ;; procedure is valid.  If the code is not valid, the check procedure
 313 ;; must return #f.  If the code is valid, the check procedure must
 314 ;; return the length of the code sequence in bytes.  The assembler
 315 ;; will try each check procedure in order until it finds one that does
 316 ;; not return #f (the last check procedure must never return #f).  For
 317 ;; convenience, the code block and current position in the code
 318 ;; sequence is passed as the two arguments of check and production
 319 ;; procedures.
 320 ;;
 321 ;; Here is a sample call of asm-at-assembly to produce the
 322 ;; shortest branch instruction to branch to label x for a
 323 ;; hypothetical processor:
 324 ;;
 325 ;;  (asm-at-assembly
 326 ;;
 327 ;;    cb
 328 ;;
 329 ;;    (lambda (cb self) ;; first check procedure
 330 ;;      (let ((dist (fx- (asm-label-pos x) self)))
 331 ;;        (if (and (fx>= dist -128) (fx<= dist 127)) ;; short branch possible?
 332 ;;            2
 333 ;;            #f)))
 334 ;;
 335 ;;    (lambda (cb self) ;; first production procedure
 336 ;;      (asm-8 cb #x34) ;; branch opcode for 8 bit displacement
 337 ;;      (asm-8 cb (fx- (asm-label-pos x) self)))
 338 ;;
 339 ;;    (lambda (cb self) 5) ;; second check procedure
 340 ;;
 341 ;;    (lambda (cb self) ;; second production procedure
 342 ;;      (asm-8 cb #x35) ;; branch opcode for 32 bit displacement
 343 ;;      (asm-32 cb (fx- (asm-label-pos x) self))))
 344
 345 (define (asm-at-assembly cb . procs)
 346   (asm-code-extend cb (vector 'deferred procs 0)))
 347
 348 ;; (asm-listing cb text) adds text to the right side of the listing.
 349 ;; The atoms in text will be output using the display procedure.  The
 350 ;; listing is generated by calling asm-display-listing.
 351
 352 (define (asm-listing cb text)
 353   (asm-code-extend cb (vector 'listing text)))
 354
 355 ;; (asm-separated-list lst sep) returns a list which, when displayed
 356 ;; in a listing, will display each element of the list lst separated
 357 ;; with the string sep.
 358
 359 (define (asm-separated-list lst sep)
 360   (if (pair? lst)
 361       (cons (car lst)
 362             (map (lambda (x) (list sep x))
 363                  (cdr lst)))
 364       lst))
 365
 366 ;; (asm-display-listing cb port encoding?) produces a listing of the
 367 ;; code block on the given output port.  The listing contains the text
 368 ;; inserted by asm-listing.  When encoding? is true, the bytes
 369 ;; generated are shown in hexadecimal on the left side of the listing.
 370
 371 (define (asm-display-listing cb #!optional (port (current-output-port)) (encoding? #f))
 372
 373   (define text-col 24)
 374   (define pos-width 6)
 375   (define byte-width 2)
 376   (define pos-radix 16)
 377
 378   (define (output text)
 379     (cond ((null? text))
 380           ((pair? text)
 381            (output (car text))
 382            (output (cdr text)))
 383           (else
 384            (display text port))))
 385
 386   (define (print-digit n)
 387     (display (string-ref "0123456789abcdef" n) port))
 388
 389   (define (print-byte n)
 390     (print-digit (fxquotient n 16))
 391     (print-digit (fxmodulo n 16)))
 392
 393   (define (print-pos n)
 394
 395     (define (p n i)
 396       (if (fx> i 0)
 397           (if (fx< n 0)
 398               (begin
 399                 (p n (fx- i 1))
 400                 (output " "))
 401               (begin
 402                 (p (fxquotient n pos-radix) (fx- i 1))
 403                 (print-digit (fxmodulo n pos-radix))))))
 404
 405     (p n pos-width))
 406
 407   (let loop1 ((lst (cdr (asm-code-block-stream cb)))
 408               (pos (asm-code-block-start-pos cb))
 409               (col 0))
 410     (if (pair? lst)
 411         (let ((x (car lst)))
 412           (if (vector? x)
 413               (let ((kind (vector-ref x 0)))
 414                 (cond ((eq? kind 'listing)
 415                        (if encoding?
 416                            (let ((col
 417                                   (if (fx= col 0)
 418                                       (begin
 419                                         (print-pos pos)
 420                                         pos-width)
 421                                       col)))
 422                              (let loop2 ((col col))
 423                                (if (fx< col text-col)
 424                                    (begin
 425                                      (display (integer->char 9) port)
 426                                      (loop2 (fx* 8 (fx+ (fxquotient col 8) 1))))))))
 427                        (output (vector-ref x 1))
 428                        (newline port)
 429                        (loop1 (cdr lst) pos 0))
 430                       (else
 431                        ;;(loop1 (cdr lst) pos col)
 432                        (compiler-internal-error
 433                         "asm-display-listing, code stream not assembled"))))
 434               (cond ((not encoding?)
 435                      (loop1 (cdr lst) (fx+ pos 1) col))
 436                     ((or (fx= col 0) (fx>= col (fx- text-col byte-width)))
 437                      (if (not (fx= col 0)) (newline port))
 438                      (print-pos pos)
 439                      (display " " port)
 440                      (print-byte x)
 441                      (loop1 (cdr lst) (fx+ pos 1) (fx+ (fx+ pos-width 1) byte-width)))
 442                     (else
 443                      (print-byte x)
 444                      (loop1 (cdr lst) (fx+ pos 1) (fx+ col byte-width))))))
 445         (if (fx> col 0)
 446             (newline port)))))
 447
 448 ;; (asm-assemble cb) assembles the code block and returns the number
 449 ;; of bytes in the code block.  After assembly, the label objects will
 450 ;; be set to their final position and the alignment bytes and the
 451 ;; deferred code will have been produced.  It is possible to extend
 452 ;; the code block after assembly.  However, if any of the procedures
 453 ;; "asm-label", "asm-align", "asm-origin", and "asm-at-assembly" are
 454 ;; called, the code block will have to be assembled once more.
 455
 456 (define (asm-assemble cb)
 457
 458   (define (pass1)
 459
 460     ;; construct fixup list and make first label assignment
 461
 462     (let loop ((curr (cdr (asm-code-block-stream cb)))
 463                (fixup-lst '())
 464                (span 0)
 465                (pos (asm-code-block-start-pos cb)))
 466       (if (pair? curr)
 467           (let ((x (car curr)))
 468             (if (vector? x)
 469                 (let ((kind (vector-ref x 0)))
 470                   (cond ((eq? kind 'label)
 471                          ;; make first approximation of label's position
 472                          (vector-set! x 1 pos)
 473                          (loop (cdr curr)
 474                                (cons (cons span curr) fixup-lst)
 475                                0
 476                                pos))
 477                         ((eq? kind 'deferred)
 478                          (loop (cdr curr)
 479                                (cons (cons span curr) fixup-lst)
 480                                0
 481                                pos))
 482                         (else
 483                          (loop (cdr curr)
 484                                fixup-lst
 485                                span
 486                                pos))))
 487                 (loop (cdr curr)
 488                       fixup-lst
 489                       (fx+ span 1)
 490                       (fx+ pos 1))))
 491           (reverse fixup-lst))))
 492
 493   (let ((fixup-lst (pass1)))
 494
 495     (let loop1 ()
 496
 497       ;; determine size of deferred code given current label positions
 498
 499       (let loop2 ((lst fixup-lst)
 500                   (pos (asm-code-block-start-pos cb))
 501                   (changed? #f))
 502         (if (pair? lst)
 503             (let* ((fixup (car lst))
 504                    (pos (fx+ pos (car fixup)))
 505                    (curr (cdr fixup))
 506                    (x (car curr)))
 507               (if (eq? (vector-ref x 0) 'label)
 508                   ;; label
 509                   (loop2 (cdr lst) pos changed?)
 510                   ;; deferred
 511                   (let ((old-size (vector-ref x 2)))
 512                     (let loop3 ()
 513                       (let* ((check (car (vector-ref x 1)))
 514                              (new-size (check cb pos)))
 515                         (if new-size
 516                             (if (fx= old-size new-size)
 517                                 (loop2 (cdr lst) (fx+ pos old-size) changed?)
 518                                 (begin
 519                                   ;; set the new size of the deferred code
 520                                   (vector-set! x 2 new-size)
 521                                   ;; position must advance according to old size
 522                                   (loop2 (cdr lst) (fx+ pos old-size) #t)))
 523                             (begin
 524                               ;; discard current check/production procedures
 525                               (vector-set! x 1 (cddr (vector-ref x 1)))
 526                               (loop3))))))))
 527
 528             ;; determine label positions given new size of deferred code
 529
 530             (let loop4 ((lst fixup-lst)
 531                         (pos (asm-code-block-start-pos cb))
 532                         (changed? changed?))
 533               (if (pair? lst)
 534                   (let* ((fixup (car lst))
 535                          (pos (fx+ pos (car fixup)))
 536                          (curr (cdr fixup))
 537                          (x (car curr)))
 538                     (if (eq? (vector-ref x 0) 'label)
 539                         ;; label
 540                         (if (fx= (vector-ref x 1) pos)
 541                             (loop4 (cdr lst) pos changed?)
 542                             (begin
 543                               (vector-set! x 1 pos)
 544                               (loop4 (cdr lst) pos #t)))
 545                         ;; deferred
 546                         (let ((new-size (vector-ref x 2)))
 547                           (loop4 (cdr lst) (fx+ pos new-size) changed?))))
 548
 549                   ;; repeat if one or more labels changed position
 550
 551                   (if changed?
 552                       (loop1)))))))
 553
 554     ;; generate deferred code by calling production procedures
 555
 556     (let loop5 ((prev (asm-code-block-stream cb))
 557                 (curr (cdr (asm-code-block-stream cb)))
 558                 (pos (asm-code-block-start-pos cb)))
 559       (if (pair? curr)
 560           (let ((x (car curr))
 561                 (next (cdr curr)))
 562             (if (vector? x)
 563                 (let ((kind (vector-ref x 0)))
 564                   (cond ((eq? kind 'label)
 565                          (let ((final-pos (vector-ref x 1)))
 566                            (if final-pos
 567                                (if (not (fx= pos final-pos))
 568                                    (compiler-internal-error
 569                                     "asm-assemble, inconsistency detected"))
 570                                (vector-set! x 1 pos))
 571                            ;; remove label
 572                            (set-cdr! prev next)
 573                            (loop5 prev next pos)))
 574                         ((eq? kind 'deferred)
 575                          (let ((temp (asm-code-block-stream cb)))
 576                            (asm-code-block-stream-set! cb (asm-make-stream))
 577                            (let ((production (cadr (vector-ref x 1))))
 578                              (production cb pos))
 579                            (let ((tail (car (asm-code-block-stream cb))))
 580                              (set-cdr! tail next))
 581                            (let ((head (cdr (asm-code-block-stream cb))))
 582                              (set-cdr! prev head)
 583                              (asm-code-block-stream-set! cb temp)
 584                              (loop5 prev head pos))))
 585                         (else
 586                          (loop5 curr next pos))))
 587                 (loop5 curr next (fx+ pos 1))))
 588           (begin
 589             (set-car! (asm-code-block-stream cb) prev)
 590             (fx- pos (asm-code-block-start-pos cb)))))))
 591
 592 ;; (asm-assemble-to-file cb filename) assembles the code block and
 593 ;; writes it to a file.
 594
 595 (define (asm-assemble-to-file cb filename)
 596   (asm-assemble cb)
 597   (with-output-to-file filename
 598     (lambda ()
 599       (let loop ((lst (cdr (asm-code-block-stream cb))))
 600         (if (pair? lst)
 601             (let ((x (car lst)))
 602               (if (vector? x)
 603                   (let ((kind (vector-ref x 0)))
 604                     (if (not (eq? kind 'listing))
 605                         (compiler-internal-error
 606                          "asm-write-code, code stream not assembled"))
 607                     (loop (cdr lst)))
 608                   (begin
 609                     (write-char (integer->char x))
 610                     (loop (cdr lst))))))))))
 611
 612 ;; (asm-assemble-to-u8vector cb) assembles the code block and converts
 613 ;; it to a u8vector containing the sequence of bytes.
 614
 615 (define (asm-assemble-to-u8vector cb)
 616   (let* ((len (asm-assemble cb))
 617          (u8v (make-u8vector len 0)))
 618     (let loop ((lst (cdr (asm-code-block-stream cb)))
 619                (pos 0))
 620         (if (pair? lst)
 621             (let ((x (car lst)))
 622               (if (vector? x)
 623                   (let ((kind (vector-ref x 0)))
 624                     (if (not (eq? kind 'listing))
 625                         (compiler-internal-error
 626                          "asm-write-code, code stream not assembled"))
 627                     (loop (cdr lst) pos))
 628                   (begin
 629                     (u8vector-set! u8v pos x)
 630                     (loop (cdr lst) (fx+ pos 1)))))
 631             u8v))))
 632
 633 ;; (asm-write-hex-file cb filename) writes the code in a file using
 634 ;; the intel hex file format.
 635
 636 #;
 637 (define (asm-write-hex-file cb filename)
 638   (with-output-to-file filename
 639     (lambda ()
 640
 641       (define (print-digit n)
 642         (display (string-ref "0123456789ABCDEF" n)))
 643
 644       (define (print-byte n)
 645         (print-digit (fxquotient n 16))
 646         (print-digit (fxmodulo n 16)))
 647
 648       (define (print-line type addr bytes)
 649         (let ((n (length bytes))
 650               (addr-hi (fxquotient addr 256))
 651               (addr-lo (fxmodulo addr 256)))
 652           (display ":")
 653           (print-byte n)
 654           (print-byte addr-hi)
 655           (print-byte addr-lo)
 656           (print-byte type)
 657           (for-each print-byte bytes)
 658           (let ((sum
 659                  (fxmodulo (fx- (apply fx+ n addr-hi addr-lo type bytes)) 256)))
 660             (print-byte sum)
 661             (newline))))
 662
 663       (let loop ((lst (cdr (asm-code-block-stream cb)))
 664                  (pos (asm-code-block-start-pos cb))
 665                  (rev-bytes '()))
 666         (if (pair? lst)
 667             (let ((x (car lst)))
 668               (if (vector? x)
 669                   (let ((kind (vector-ref x 0)))
 670                     (if (not (eq? kind 'listing))
 671                         (compiler-internal-error
 672                          "asm-write-hex-file, code stream not assembled"))
 673                     (loop (cdr lst)
 674                           pos
 675                           rev-bytes))
 676                   (let ((new-pos
 677                          (fx+ pos 1))
 678                         (new-rev-bytes
 679                          (cons x
 680                                (if (fx= (fxmodulo pos 16) 0)
 681                                    (begin
 682                                      (print-line 0
 683                                                  (fx- pos (length rev-bytes))
 684                                                  (reverse rev-bytes))
 685                                      '())
 686                                    rev-bytes))))
 687                     (loop (cdr lst)
 688                           new-pos
 689                           new-rev-bytes))))
 690             (begin
 691               (if (pair? rev-bytes)
 692                   (print-line 0
 693                               (fx- pos (length rev-bytes))
 694                               (reverse rev-bytes)))
 695               (print-line 1 0 '())
 696               pos))))))
 697
 698 ;; Utilities.
 699
 700 (define (asm-make-stream) ;; create an empty stream
 701   (let ((x (cons '() '())))
 702     (set-car! x x)
 703     x))
 704
 705 (define (asm-code-extend cb item) ;; add an item at the end of current code stream
 706   (let* ((stream (asm-code-block-stream cb))
 707          (tail (car stream))
 708          (cell (cons item '())))
 709     (set-cdr! tail cell)
 710     (set-car! stream cell)))
 711
 712 (declare (generic)) ;; following code operates on bignums and flonums
 713
 714 (define (asm-signed8? n) ;; is n a signed 8 bit integer?
 715   (and (<= #x-80 n) (<= n #x7f)))
 716
 717 (define (asm-signed16? n) ;; is n a signed 16 bit integer?
 718   (and (<= #x-8000 n) (<= n #x7fff)))
 719
 720 (define (asm-signed32? n) ;; is n a signed 32 bit integer?
 721   (and (<= #x-80000000 n) (<= n #x7fffffff)))
 722
 723 (define (asm-signed-lo8 n) ;; return low 8 bits of n as a signed integer
 724   (- (bitwise-and (+ n #x80) #xff)
 725      #x80))
 726
 727 (define (asm-unsigned-lo8 n) ;; return low 8 bits of n as an unsigned integer
 728   (bitwise-and n #xff))
 729
 730 (define (asm-signed-lo16 n) ;; return low 16 bits of n as a signed integer
 731   (- (bitwise-and (+ n #x8000) #xffff)
 732      #x8000))
 733
 734 (define (asm-unsigned-lo16 n) ;; return low 16 bits of n as an unsigned integer
 735   (bitwise-and n #xffff))
 736
 737 (define (asm-signed-lo32 n) ;; return low 32 bits of n as a signed integer
 738   (- (bitwise-and (+ n #x80000000) #xffffffff)
 739      #x80000000))
 740
 741 (define (asm-unsigned-lo32 n) ;; return low 32 bits of n as an unsigned integer
 742   (bitwise-and n #xffffffff))
 743
 744 (define (asm-signed-lo64 n) ;; return low 64 bits of n as a signed integer
 745   (- (bitwise-and (+ n #x8000000000000000) #xffffffffffffffff)
 746      #x8000000000000000))
 747
 748 (define (asm-unsigned-lo64 n) ;; return low 64 bits of n as an unsigned integer
 749   (bitwise-and n #xffffffffffffffff))
 750
 751 (define (asm-signed-lo n width) ;; return low "width" bits of n as a signed integer
 752   (case width
 753     ((8)
 754      (asm-signed-lo8 n))
 755     ((16)
 756      (asm-signed-lo16 n))
 757     ((32)
 758      (asm-signed-lo32 n))
 759     ((64)
 760      (asm-signed-lo64 n))
 761     (else
 762      (error "unsupported width" width))))
 763
 764 (define (asm-unsigned-lo n width) ;; return low "width" bits of n
 765   (case width
 766     ((8)
 767      (asm-unsigned-lo8 n))
 768     ((16)
 769      (asm-unsigned-lo16 n))
 770     ((32)
 771      (asm-unsigned-lo32 n))
 772     ((64)
 773      (asm-unsigned-lo64 n))
 774     (else
 775      (error "unsupported width" width))))
 776
 777 ;; TODO: improve implementation of following procedures
 778
 779 (define (asm-bits-0-to-7 n) ;; return bits 0 to 7 of a signed integer
 780   (modulo n #x100))
 781
 782 (define (asm-bits-8-and-up n) ;; return bits 8 and up of a signed integer
 783   (if (>= n 0)
 784       (quotient n #x100)
 785       (- (quotient (+ n 1) #x100) 1)))
 786
 787 (define (asm-bits-16-and-up n) ;; return bits 16 and up of a signed integer
 788   (if (>= n 0)
 789       (quotient n #x10000)
 790       (- (quotient (+ n 1) #x10000) 1)))
 791
 792 (define (asm-bits-32-and-up n) ;; return bits 32 and up of a signed integer
 793   (if (>= n 0)
 794       (quotient n #x100000000)
 795       (- (quotient (+ n 1) #x100000000) 1)))
 796
 797 ;; The following procedures convert floating point numbers into their
 798 ;; ANSI-IEEE Std 754-1985 representation (32 bit and 64 bit floats).
 799 ;; They perform bignum and flonum arithmetic.
 800
 801 (define asm-inexact-+2   (exact->inexact 2))
 802 (define asm-inexact--2   (exact->inexact -2))
 803 (define asm-inexact-+1   (exact->inexact 1))
 804 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
 805 (define asm-inexact-+0   (exact->inexact 0))
 806
 807 (define (asm-float->inexact-exponential-format x f64?)
 808   (let* ((e-bits (if f64? 11 8))
 809          (e-bias (- (expt 2 (- e-bits 1)) 1)))
 810
 811     (define (float-copysign x y)
 812       (if (negative? y)
 813           (- x)
 814           x))
 815
 816     (define (exp-form-pos x y i)
 817       (let ((i*2 (+ i i)))
 818         (let ((z (if (and (not (< e-bias i*2))
 819                           (not (< x y)))
 820                      (exp-form-pos x (* y y) i*2)
 821                      (vector x 0 1))))
 822           (let ((a (vector-ref z 0)) (b (vector-ref z 1)))
 823             (let ((i+b (+ i b)))
 824               (if (and (not (< e-bias i+b))
 825                        (not (< a y)))
 826                   (begin
 827                     (vector-set! z 0 (/ a y))
 828                     (vector-set! z 1 i+b)))
 829               z)))))
 830
 831     (define (exp-form-neg x y i)
 832       (let ((i*2 (+ i i)))
 833         (let ((z (if (and (< i*2 (- e-bias 1))
 834                           (< x y))
 835                      (exp-form-neg x (* y y) i*2)
 836                      (vector x 0 1))))
 837           (let ((a (vector-ref z 0)) (b (vector-ref z 1)))
 838             (let ((i+b (+ i b)))
 839               (if (and (< i+b (- e-bias 1))
 840                        (< a y))
 841                   (begin
 842                     (vector-set! z 0 (/ a y))
 843                     (vector-set! z 1 i+b)))
 844               z)))))
 845
 846     (define (exp-form x)
 847       (if (< x asm-inexact-+1)
 848           (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
 849             (vector-set! z 0 (* asm-inexact-+2 (vector-ref z 0)))
 850             (vector-set! z 1 (- -1 (vector-ref z 1)))
 851             z)
 852           (exp-form-pos x asm-inexact-+2 1)))
 853
 854     (if (negative? (float-copysign asm-inexact-+1 x))
 855         (let ((z (exp-form (float-copysign x asm-inexact-+1))))
 856           (vector-set! z 2 -1)
 857           z)
 858         (exp-form x))))
 859
 860 (define (asm-float->exact-exponential-format x f64?)
 861   (let* ((z      (asm-float->inexact-exponential-format x f64?))
 862          (m-bits (if f64? 52 23))
 863          (e-bits (if f64? 11 8)))
 864
 865     (let ((y (vector-ref z 0)))
 866       (if (not (< y asm-inexact-+2)) ;; +inf.0 or +nan.0?
 867           (begin
 868             (if (< asm-inexact-+0 y)
 869                 (vector-set! z 0 (expt 2 m-bits))              ;; +inf.0
 870                 (vector-set! z 0 (- (* (expt 2 m-bits) 2) 1))) ;; +nan.0
 871             (vector-set! z 1 (expt 2 (- e-bits 1))))
 872           (vector-set! z 0
 873                        (truncate
 874                         (inexact->exact
 875                          (* (vector-ref z 0)
 876                             (exact->inexact (expt 2 m-bits)))))))
 877       (vector-set! z 1 (- (vector-ref z 1) m-bits))
 878       z)))
 879
 880 (define (asm-float->bits x f64?)
 881   (let ((m-bits (if f64? 52 23))
 882         (e-bits (if f64? 11 8)))
 883
 884     (define (bits a b)
 885       (let ((m-min (expt 2 m-bits)))
 886         (if (< a m-min)
 887           a
 888           (+ (- a m-min)
 889              (* (+ (+ b m-bits) (- (expt 2 (- e-bits 1)) 1))
 890                 m-min)))))
 891
 892     (let* ((z (asm-float->exact-exponential-format x f64?))
 893            (y (bits (vector-ref z 0) (vector-ref z 1))))
 894       (if (negative? (vector-ref z 2))
 895         (+ (expt 2 (+ e-bits m-bits)) y)
 896         y))))
 897
 898 ;;;============================================================================