diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index e3e31a0be..fc4b21a43 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -153,8 +153,13 @@ label (match (lookup-cont label dfg) (($ $kclause) label) - (($ $kargs _ _ term) + (($ $kargs names vars term) (emit-label asm label) + (for-each (lambda (name var) + (let ((slot (maybe-slot var))) + (when slot + (emit-definition asm name slot)))) + names vars) (let find-exp ((term term)) (match term (($ $letk conts term) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 7f4b1bdc5..ad7eb2376 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -163,7 +163,7 @@ ;; Metadata for one . (define-record-type (make-arity req opt rest kw-indices allow-other-keys? - low-pc high-pc) + low-pc high-pc definitions) arity? (req arity-req) (opt arity-opt) @@ -171,7 +171,8 @@ (kw-indices arity-kw-indices) (allow-other-keys? arity-allow-other-keys?) (low-pc arity-low-pc) - (high-pc arity-high-pc set-arity-high-pc!)) + (high-pc arity-high-pc set-arity-high-pc!) + (definitions arity-definitions set-arity-definitions!)) (define-syntax *block-size* (identifier-syntax 32)) @@ -753,7 +754,7 @@ returned instead." (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)) + (asm-start asm) #f '())) ;; The procedure itself is in slot 0, in the standard calling ;; convention. For procedure prologues, nreq includes the ;; procedure, so here we add 1. @@ -772,6 +773,7 @@ returned instead." (define-macro-assembler (end-arity asm) (let ((arity (car (meta-arities (car (asm-meta asm)))))) + (set-arity-definitions! arity (reverse (arity-definitions arity))) (set-arity-high-pc! arity (asm-start asm)))) (define-macro-assembler (standard-prelude asm nreq nlocals alternate) @@ -825,6 +827,11 @@ returned instead." (define-macro-assembler (source asm source) (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm)))) +(define-macro-assembler (definition asm name slot) + (let* ((arity (car (meta-arities (car (asm-meta asm))))) + (def (vector name slot (- (asm-start asm) (arity-low-pc arity))))) + (set-arity-definitions! arity (cons def (arity-definitions arity))))) + (define-macro-assembler (cache-current-module! asm module scope) (let ((mod-label (intern-module-cache-cell asm scope))) (emit-static-set! asm module mod-label 0)))