diff options
Diffstat (limited to 'module/system/vm/assembler.scm')
-rw-r--r-- | module/system/vm/assembler.scm | 59 |
1 files changed, 55 insertions, 4 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index b5b2db8eb..5969dbf8b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -122,21 +122,35 @@ (error (string-append "expected " kind) x)))) (define-record-type <meta> - (%make-meta label properties low-pc high-pc) + (%make-meta label properties low-pc high-pc arities) meta? (label meta-label) (properties meta-properties set-meta-properties!) (low-pc meta-low-pc) - (high-pc meta-high-pc set-meta-high-pc!)) + (high-pc meta-high-pc set-meta-high-pc!) + (arities meta-arities set-meta-arities!)) (define (make-meta label properties low-pc) (assert-match label (? symbol?) "symbol") (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys") - (%make-meta label properties low-pc #f)) + (%make-meta label properties low-pc #f '())) (define (meta-name meta) (assq-ref (meta-properties meta) 'name)) +;; Metadata for one <lambda-case>. +(define-record-type <arity> + (make-arity req opt rest kw-indices allow-other-keys? + low-pc high-pc) + arity? + (req arity-req) + (opt arity-opt) + (rest arity-rest) + (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!)) + (define-syntax *block-size* (identifier-syntax 32)) ;;; An assembler collects all of the words emitted during assembly, and @@ -624,7 +638,44 @@ returned instead." (define-macro-assembler (end-program asm) (let ((meta (car (asm-meta asm)))) - (set-meta-high-pc! meta (asm-start asm)))) + (set-meta-high-pc! meta (asm-start asm)) + (set-meta-arities! meta (reverse (meta-arities meta))))) + +(define-macro-assembler (begin-standard-arity asm req nlocals alternate) + (emit-begin-opt-arity asm req '() #f nlocals alternate)) + +(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate) + (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate)) + +(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices + allow-other-keys? nlocals alternate) + (assert-match req ((? symbol?) ...) "list of symbols") + (assert-match opt ((? symbol?) ...) "list of symbols") + (assert-match rest (or #f (? symbol?)) "#f or symbol") + (assert-match kw-indices (((? symbol?) . (? integer?)) ...) + "alist of symbol -> integer") + (assert-match allow-other-keys? (? boolean?) "boolean") + (assert-match nlocals (? integer?) "integer") + (assert-match alternate (or #f (? 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)) + (nreq (length req)) + (nopt (length opt)) + (rest? (->bool rest))) + (set-meta-arities! meta (cons arity (meta-arities meta))) + (cond + ((or allow-other-keys? (pair? kw-indices)) + (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? + nlocals alternate)) + ((or rest? (pair? opt)) + (emit-opt-prelude asm nreq nopt rest? nlocals alternate)) + (else + (emit-standard-prelude asm nreq nlocals alternate))))) + +(define-macro-assembler (end-arity asm) + (let ((arity (car (meta-arities (car (asm-meta asm)))))) + (set-arity-high-pc! arity (asm-start asm)))) (define-macro-assembler (standard-prelude asm nreq nlocals alternate) (cond |