mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
parent
ecc7987427
commit
9a1dfb7d2e
4 changed files with 70 additions and 41 deletions
|
@ -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))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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,17 +627,19 @@ indicates that the replacement variable is in a box."
|
|||
(tree-il-fold box-set-vars default-args '() exp))
|
||||
|
||||
(define (cps-convert/thunk exp)
|
||||
(let ((src (tree-il-src exp)))
|
||||
(let-gensyms (kinit init ktail kclause kbody)
|
||||
(build-cps-exp
|
||||
($fun src '() '()
|
||||
(kinit ($kentry init
|
||||
(ktail ($ktail))
|
||||
((kclause
|
||||
($kclause ('() '() #f '() #f)
|
||||
(kbody ($kargs () ()
|
||||
,(convert exp ktail
|
||||
(build-subst exp))))))))))))))
|
||||
(parameterize ((label-counter 0)
|
||||
(var-counter 0))
|
||||
(let ((src (tree-il-src exp)))
|
||||
(let-fresh (kinit ktail kclause kbody) (init)
|
||||
(build-cps-exp
|
||||
($fun src '() '()
|
||||
(kinit ($kentry init
|
||||
(ktail ($ktail))
|
||||
((kclause
|
||||
($kclause ('() '() #f '() #f)
|
||||
(kbody ($kargs () ()
|
||||
,(convert exp ktail
|
||||
(build-subst exp)))))))))))))))
|
||||
|
||||
(define *comp-module* (make-fluid))
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue