Continuation labels and variable identifiers may be integers

* module/language/cps.scm (label-counter, var-counter): New parameters,
  for producing fresh label and var names.
  (fresh-label, fresh-var): New procedures.
  (let-fresh): New macro, will replace let-gensyms.
  (build-cps-term): Use let-fresh.

* module/language/tree-il/compile-cps.scm: Use let-fresh to generate
  fresh names.

* module/system/vm/assembler.scm (make-meta, begin-kw-arity): Allow
  exact integers as labels.
  (link-debug): Explicitly mark low-pc as being an "addr" value.

.dir-locals.el

@@ -12,6 +12,7 @@
      (eval . (put 'with-code-coverage  'scheme-indent-function 1))
      (eval . (put 'with-statprof       'scheme-indent-function 1))
      (eval . (put 'let-gensyms         'scheme-indent-function 1))
+     (eval . (put 'let-fresh           'scheme-indent-function 2))
      (eval . (put 'build-cps-term      'scheme-indent-function 0))
      (eval . (put 'build-cps-exp       'scheme-indent-function 0))
      (eval . (put 'build-cps-cont      'scheme-indent-function 0))

module/language/cps.scm

@@ -123,8 +123,12 @@
             ;; Expressions.
             $void $const $prim $fun $call $callk $primcall $values $prompt
 
+            ;; Fresh names.
+            label-counter var-counter
+            fresh-label fresh-var
+            let-fresh let-gensyms
+
             ;; Building macros.
-            let-gensyms
             build-cps-term build-cps-cont build-cps-exp
             rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
 
@@ -187,6 +191,26 @@
 (define-cps-type $values args)
 (define-cps-type $prompt escape? tag handler)
 
+(define label-counter (make-parameter #f))
+(define var-counter (make-parameter #f))
+
+(define (fresh-label)
+  (let ((count (label-counter)))
+    (label-counter (1+ count))
+    count))
+
+;; FIXME: Currently vars and labels need to be unique, so we use the
+;; label counter.
+(define (fresh-var)
+  (let ((count (label-counter)))
+    (label-counter (1+ count))
+    count))
+
+(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
+  (let ((label (fresh-label)) ...
+        (var (fresh-var)) ...)
+    body ...))
+
 (define-syntax let-gensyms
   (syntax-rules ()
     ((_ (sym ...) body body* ...)
@@ -261,7 +285,7 @@
     ((_ ($letconst () body))
      (build-cps-term body))
     ((_ ($letconst ((name sym val) tail ...) body))
-     (let-gensyms (kconst)
+     (let-fresh (kconst) ()
        (build-cps-term
          ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
            ($continue kconst (let ((props (source-properties val)))

module/language/tree-il/compile-cps.scm

@@ -77,7 +77,7 @@
 (define current-topbox-scope (make-parameter #f))
 
 (define (toplevel-box src name bound? val-proc)
-  (let-gensyms (name-sym bound?-sym kbox box)
+  (let-fresh (kbox) (name-sym bound?-sym box)
     (build-cps-term
       ($letconst (('name name-sym name)
                   ('bound? bound?-sym bound?))
@@ -89,7 +89,7 @@
                   ($primcall 'resolve
                              (name-sym bound?-sym)))))
              (scope
-              (let-gensyms (scope-sym)
+              (let-fresh () (scope-sym)
                 (build-cps-term
                   ($letconst (('scope scope-sym scope))
                     ($continue kbox src
@@ -97,7 +97,7 @@
                                  (scope-sym name-sym bound?-sym)))))))))))))
 
 (define (module-box src module name public? bound? val-proc)
-  (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+  (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
     (build-cps-term
       ($letconst (('module module-sym module)
                   ('name name-sym name)
@@ -109,7 +109,7 @@
                        (module-sym name-sym public?-sym bound?-sym))))))))
 
 (define (capture-toplevel-scope src scope k)
-  (let-gensyms (module scope-sym kmodule)
+  (let-fresh (kmodule) (module scope-sym)
     (build-cps-term
       ($letconst (('scope scope-sym scope))
         ($letk ((kmodule ($kargs ('module) (module)
@@ -159,9 +159,10 @@
   (define tc8-iflag 4)
   (define unbound-val 9)
   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
-  (let-gensyms (unbound ktest)
+  (let-fresh (ktest) (unbound)
     (build-cps-term
-      ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+      ($letconst (('unbound unbound
+                            (pointer->scm (make-pointer unbound-bits))))
         ($letk ((ktest ($kif kt kf)))
           ($continue ktest src
             ($primcall 'eq? (sym unbound))))))))
@@ -172,13 +173,13 @@
      (let ((src (tree-il-src init)))
        (define (maybe-box k make-body)
          (if box?
-             (let-gensyms (kbox phi)
+             (let-fresh (kbox) (phi)
                (build-cps-term
                  ($letk ((kbox ($kargs (name) (phi)
                                  ($continue k src ($primcall 'box (phi))))))
                    ,(make-body kbox))))
              (make-body k)))
-       (let-gensyms (knext kbound kunbound kreceive krest val rest)
+       (let-fresh (knext kbound kunbound kreceive krest) (val rest)
          (build-cps-term
            ($letk ((knext ($kargs (name) (subst-sym) ,body)))
              ,(maybe-box
@@ -202,14 +203,14 @@
       (($ <lexical-ref> src name sym)
        (match (assq-ref subst sym)
          ((box #t)
-          (let-gensyms (kunboxed unboxed)
+          (let-fresh (kunboxed) (unboxed)
             (build-cps-term
               ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
                 ($continue kunboxed src ($primcall 'box-ref (box)))))))
          ((subst #f) (k subst))
          (#f (k sym))))
       (else
-       (let-gensyms (kreceive karg arg rest)
+       (let-fresh (kreceive karg) (arg rest)
          (build-cps-term
            ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
                    (kreceive ($kreceive '(arg) 'rest karg)))
@@ -227,7 +228,7 @@
   (define (box-bound-var name sym body)
     (match (assq-ref subst sym)
       ((box #t)
-       (let-gensyms (k)
+       (let-fresh (k) ()
          (build-cps-term
            ($letk ((k ($kargs (name) (box) ,body)))
              ($continue k #f ($primcall 'box (sym)))))))
@@ -262,7 +263,7 @@
                                         '()
                                         arity gensyms inits)))
               (cons
-               (let-gensyms (kclause kargs)
+               (let-fresh (kclause kargs) ()
                  (build-cps-cont
                    (kclause
                     ($kclause ,arity
@@ -277,13 +278,13 @@
                            arity gensyms inits)))))))
                (convert-clauses alternate ktail))))))
        (if (current-topbox-scope)
-           (let-gensyms (kentry self ktail)
+           (let-fresh (kentry ktail) (self)
              (build-cps-term
                ($continue k fun-src
                  ($fun fun-src meta '()
                        (kentry ($kentry self (ktail ($ktail))
                                  ,(convert-clauses body ktail)))))))
-           (let-gensyms (scope kscope)
+           (let-fresh (kscope) (scope)
              (build-cps-term
                ($letk ((kscope ($kargs () ()
                                  ,(parameterize ((current-topbox-scope scope))
@@ -323,7 +324,7 @@
     (($ <toplevel-define> src name exp)
      (convert-arg exp
        (lambda (val)
-         (let-gensyms (kname name-sym)
+         (let-fresh (kname) (name-sym)
            (build-cps-term
              ($letconst (('name name-sym name))
                ($continue k src ($primcall 'define! (name-sym val)))))))))
@@ -360,7 +361,7 @@
        ;; it's quite tricky there and quite easy here, so hold your nose
        ;; while we drop some smelly code.
        (convert (let ((len (length args)))
-                  (let-gensyms (v)
+                  (let-fresh () (v)
                     (make-let src
                               (list 'v)
                               (list v)
@@ -394,7 +395,7 @@
             (build-cps-term
               ($continue k src ($const '()))))
            ((arg . args)
-            (let-gensyms (ktail tail)
+            (let-fresh (ktail) (tail)
               (build-cps-term
                 ($letk ((ktail ($kargs ('tail) (tail)
                                  ,(convert-arg arg
@@ -427,7 +428,7 @@
      (convert-arg tag
        (lambda (tag)
          (let ((hnames (append hreq (if hrest (list hrest) '()))))
-           (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+           (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
              (build-cps-term
                ;; FIXME: Attach hsrc to $kreceive.
                ($letk* ((khbody ($kargs hnames hsyms
@@ -465,7 +466,8 @@
 
     ;; Eta-convert prompts without inline handlers.
     (($ <prompt> src escape-only? tag body handler)
-     (let-gensyms (h args)
+     (let ((h (gensym "h "))
+           (args (gensym "args ")))
        (convert
         (make-let
          src (list 'h) (list h) (list handler)
@@ -514,7 +516,7 @@
            ($continue k src ($primcall 'apply args*))))))
 
     (($ <conditional> src test consequent alternate)
-     (let-gensyms (kif kt kf)
+     (let-fresh (kif kt kf) ()
        (build-cps-term
          ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
                   (kf ($kargs () () ,(convert alternate k subst)))
@@ -539,7 +541,7 @@
               ($continue k src ($primcall 'box-set! (box exp)))))))))
 
     (($ <seq> src head tail)
-     (let-gensyms (kreceive kseq vals)
+     (let-fresh (kreceive kseq) (vals)
        (build-cps-term
          ($letk* ((kseq ($kargs ('vals) (vals)
                           ,(convert tail k subst)))
@@ -551,7 +553,7 @@
        (match (list names syms vals)
          ((() () ()) (convert body k subst))
          (((name . names) (sym . syms) (val . vals))
-          (let-gensyms (kreceive klet rest)
+          (let-fresh (kreceive klet) (rest)
             (build-cps-term
               ($letk* ((klet ($kargs (name 'rest) (sym rest)
                                ,(box-bound-var name sym
@@ -562,7 +564,7 @@
     (($ <fix> src names gensyms funs body)
      ;; Some letrecs can be contified; that happens later.
      (if (current-topbox-scope)
-         (let-gensyms (self)
+         (let-fresh () (self)
            (build-cps-term
              ($letrec names
                       gensyms
@@ -572,7 +574,7 @@
                                 fun)))
                            funs)
                       ,(convert body k subst))))
-         (let-gensyms (scope kscope)
+         (let-fresh (kscope) (scope)
            (build-cps-term
              ($letk ((kscope ($kargs () ()
                                ,(parameterize ((current-topbox-scope scope))
@@ -582,7 +584,7 @@
     (($ <let-values> src exp
         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
      (let ((names (append req (if rest (list rest) '()))))
-       (let-gensyms (kreceive kargs)
+       (let-fresh (kreceive kargs) ()
          (build-cps-term
            ($letk* ((kargs ($kargs names syms
                              ,(fold box-bound-var
@@ -625,8 +627,10 @@ indicates that the replacement variable is in a box."
   (tree-il-fold box-set-vars default-args '() exp))
 
 (define (cps-convert/thunk exp)
+  (parameterize ((label-counter 0)
+                 (var-counter 0))
     (let ((src (tree-il-src exp)))
-    (let-gensyms (kinit init ktail kclause kbody)
+      (let-fresh (kinit ktail kclause kbody) (init)
         (build-cps-exp
           ($fun src '() '()
                 (kinit ($kentry init
@@ -635,7 +639,7 @@ indicates that the replacement variable is in a box."
                            ($kclause ('() '() #f '() #f)
                              (kbody ($kargs () ()
                                       ,(convert exp ktail
-                                          (build-subst exp))))))))))))))
+                                                (build-subst exp)))))))))))))))
 
 (define *comp-module* (make-fluid))
 

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 '()))
 
@@ -750,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))
@@ -1961,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)
@@ -1969,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)