Continuation labels and variable identifiers may be integers

[bpt/guile.git] / module / system / vm / assembler.scm

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 5ddc642..e6d1851 100644 (file)
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -153,7 +153,7 @@
   (arities meta-arities set-meta-arities!))
 
 (define (make-meta label properties low-pc)
-  (assert-match label (? symbol?) "symbol")
+  (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
   (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
   (%make-meta label properties low-pc #f '()))
 
@@ -604,14 +604,20 @@ table, its existing label is used directly."
         (static-set! 1 ,label 0)))
      ((uniform-vector-backing-store? obj) '())
      ((simple-uniform-vector? obj)
-      `((static-patch! ,label 2
-                       ,(recur (make-uniform-vector-backing-store
-                                (uniform-array->bytevector obj)
-                                (if (bitvector? obj)
-                                    ;; Bitvectors are addressed in
-                                    ;; 32-bit units.
-                                    4
-                                    (uniform-vector-element-size obj)))))))
+      (let ((width (case (array-type obj)
+                     ((vu8 u8 s8) 1)
+                     ((u16 s16) 2)
+                     ;; Bitvectors are addressed in 32-bit units.
+                     ;; Although a complex number is 8 or 16 bytes wide,
+                     ;; it should be byteswapped in 4 or 8 byte units.
+                     ((u32 s32 f32 c32 b) 4)
+                     ((u64 s64 f64 c64) 8)
+                     (else
+                      (error "unhandled array type" obj)))))
+        `((static-patch! ,label 2
+                         ,(recur (make-uniform-vector-backing-store
+                                  (uniform-array->bytevector obj)
+                                  width))))))
      (else
       (error "don't know how to intern" obj))))
   (cond
@@ -744,7 +750,7 @@ returned instead."
                 "alist of keyword -> integer")
   (assert-match allow-other-keys? (? boolean?) "boolean")
   (assert-match nlocals (? integer?) "integer")
-  (assert-match alternate (or #f (? symbol?)) "#f or symbol")
+  (assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or symbol")
   (let* ((meta (car (asm-meta asm)))
          (arity (make-arity req opt rest kw-indices allow-other-keys?
                             (asm-start asm) #f))
@@ -1041,7 +1047,7 @@ should be .data or .rodata), and return the resulting linker object.
        ((simple-uniform-vector? obj)
         (let ((tag (if (bitvector? obj)
                        tc7-bitvector
-                       (let ((type-code (uniform-vector-element-type-code obj)))
+                       (let ((type-code (array-type-code obj)))
                          (logior tc7-bytevector (ash type-code 7))))))
           (case word-size
             ((4)
@@ -1955,6 +1961,7 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
       (cond
        ((string? val) 'strp)
        ((eq? attr 'stmt-list) 'sec-offset)
+       ((eq? attr 'low-pc) 'addr)
        ((exact-integer? code)
         (cond
          ((< code 0) 'sleb128)
@@ -1963,7 +1970,6 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
          ((<= code #xffffffff) 'data4)
          ((<= code #xffffffffffffffff) 'data8)
          (else 'uleb128)))
-       ((symbol? val) 'addr)
        (else (error "unhandled case" attr val code))))
 
     (define (add-die-relocation! kind sym)