mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Continuation labels and variable identifiers may be integers

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-03-28 14:21:06 +01:00
parent ecc7987427
commit 9a1dfb7d2e
4 changed files with 70 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -12,6 +12,7 @@
(eval . (put 'with-code-coverage 'scheme-indent-function 1)) (eval . (put 'with-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1)) (eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms '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-term 'scheme-indent-function 0))
(eval . (put 'build-cps-exp 'scheme-indent-function 0)) (eval . (put 'build-cps-exp 'scheme-indent-function 0))
(eval . (put 'build-cps-cont 'scheme-indent-function 0)) (eval . (put 'build-cps-cont 'scheme-indent-function 0))

28
module/language/cps.scm
View file

@ -123,8 +123,12 @@
;; Expressions. ;; Expressions.
$void $const $prim $fun $call $callk $primcall $values $prompt $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. ;; Building macros.
let-gensyms
build-cps-term build-cps-cont build-cps-exp build-cps-term build-cps-cont build-cps-exp
rewrite-cps-term rewrite-cps-cont rewrite-cps-exp rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
@ -187,6 +191,26 @@
(define-cps-type $values args) (define-cps-type $values args)
(define-cps-type $prompt escape? tag handler) (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 (define-syntax let-gensyms
(syntax-rules () (syntax-rules ()
((_ (sym ...) body body* ...) ((_ (sym ...) body body* ...)
@ -261,7 +285,7 @@
((_ ($letconst () body)) ((_ ($letconst () body))
(build-cps-term body)) (build-cps-term body))
((_ ($letconst ((name sym val) tail ...) body)) ((_ ($letconst ((name sym val) tail ...) body))
(let-gensyms (kconst) (let-fresh (kconst) ()
(build-cps-term (build-cps-term
($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body)))) ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
($continue kconst (let ((props (source-properties val))) ($continue kconst (let ((props (source-properties val)))

76
module/language/tree-il/compile-cps.scm
View file

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

6
module/system/vm/assembler.scm
View file

@ -153,7 +153,7 @@
(arities meta-arities set-meta-arities!)) (arities meta-arities set-meta-arities!))
(define (make-meta label properties low-pc) (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") (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
(%make-meta label properties low-pc #f '())) (%make-meta label properties low-pc #f '()))
@ -750,7 +750,7 @@ returned instead."
"alist of keyword -> integer") "alist of keyword -> integer")
(assert-match allow-other-keys? (? boolean?) "boolean") (assert-match allow-other-keys? (? boolean?) "boolean")
(assert-match nlocals (? integer?) "integer") (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))) (let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys? (arity (make-arity req opt rest kw-indices allow-other-keys?
(asm-start asm) #f)) (asm-start asm) #f))
@ -1961,6 +1961,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(cond (cond
((string? val) 'strp) ((string? val) 'strp)
((eq? attr 'stmt-list) 'sec-offset) ((eq? attr 'stmt-list) 'sec-offset)
((eq? attr 'low-pc) 'addr)
((exact-integer? code) ((exact-integer? code)
(cond (cond
((< code 0) 'sleb128) ((< code 0) 'sleb128)
@ -1969,7 +1970,6 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
((<= code #xffffffff) 'data4) ((<= code #xffffffff) 'data4)
((<= code #xffffffffffffffff) 'data8) ((<= code #xffffffffffffffff) 'data8)
(else 'uleb128))) (else 'uleb128)))
((symbol? val) 'addr)
(else (error "unhandled case" attr val code)))) (else (error "unhandled case" attr val code))))
(define (add-die-relocation! kind sym) (define (add-die-relocation! kind sym)