From 45fdcd8301c778b604891139e0b8e32b25835785 Mon Sep 17 00:00:00 2001 From: "Brian A. LaMacchia" Date: Thu, 7 Jan 1988 21:16:19 +0000 Subject: [PATCH] Initial check-in for version 4 compiler --- v7/src/compiler/machines/vax/dassm1.scm | 146 +++++++-- v7/src/compiler/machines/vax/dassm2.scm | 401 ++++++++++++------------ v7/src/compiler/machines/vax/machin.scm | 82 ++--- 3 files changed, 356 insertions(+), 273 deletions(-) diff --git a/v7/src/compiler/machines/vax/dassm1.scm b/v7/src/compiler/machines/vax/dassm1.scm index 1ab95ea14..e5dff9a92 100644 --- a/v7/src/compiler/machines/vax/dassm1.scm +++ b/v7/src/compiler/machines/vax/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 1.1 1988/01/07 16:47:57 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm1.scm,v 4.1 1988/01/07 21:15:30 bal Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -33,30 +33,126 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; VAX Disassembler +;;; +;;; Matches version 4.2 of bobcat/dassm1.scm +;;; (declare (usual-integrations)) -(define disassembler:symbolize-output? true) - -(define disassembly-stream) -(define setup-table!) ;; Temporary -(define compiler:write-lap-file) -(define compiler:write-constants-file) - -;;; Little bit of abstraction for instructions shipped outside - -(define-integrable (make-instruction offset label? code) - (cons* offset label? code)) - -(define-integrable instruction-offset car) -(define-integrable instruction-label? cadr) -(define-integrable instruction-code cddr) - -;; INSTRUCTION-STREAM-CONS is (cons (delay )) - -(define-integrable instruction-stream? pair?) -(define-integrable instruction-stream-null? null?) -(define-integrable instruction-stream-head car) - -(define-integrable (instruction-stream-tail stream) - (force (cdr stream))) \ No newline at end of file +;;; Flags that control disassembler behavior +(define disassembler/symbolize-output? true) +(define disassembler/compiled-code-heuristics? true) +(define disassembler/write-offsets? true) + +;;; Operations exported from the disassembler package +(define disassembler/instructions) +(define disassembler/instructions/null?) +(define disassembler/instructions/read) +(define disassembler/lookup-symbol) + +(define (compiler:write-lap-file filename #!optional symbol-table?) + (let ((pathname (->pathname filename))) + (with-output-to-file (pathname-new-type pathname "lap") + (lambda () + (disassembler/write-compiled-code-block + (compiled-code-block/read-file (pathname-new-type pathname "com")) + (let ((pathname (pathname-new-type pathname "binf"))) + (and (if (unassigned? symbol-table?) + (file-exists? pathname) + symbol-table?) + (compiler-info/symbol-table + (compiler-info/read-file pathname))))))))) + +(define (disassembler/write-compiled-code-block block symbol-table) + (write-string "Code:\n\n") + (disassembler/write-instruction-stream + symbol-table + (disassembler/instructions/compiled-code-block block symbol-table)) + (write-string "\nConstants:\n\n") + (disassembler/write-constants-block block symbol-table)) + +(define (disassembler/instructions/compiled-code-block block symbol-table) + (disassembler/instructions block + (compiled-code-block/code-start block) + (compiled-code-block/code-end block) + symbol-table)) + +(define (disassembler/instructions/address start-address end-address) + (disassembler/instructions false start-address end-address false)) + +(define (disassembler/write-instruction-stream symbol-table instruction-stream) + (fluid-let ((*unparser-radix* 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (let ((string + (with-output-to-string + (lambda () + (display instruction))))) + (string-downcase! string) + (write-string string)))))))) + +(define (disassembler/for-each-instruction instruction-stream procedure) + (let loop ((instruction-stream instruction-stream)) + (if (not (disassembler/instructions/null? instruction-stream)) + (disassembler/instructions/read instruction-stream + (lambda (offset instruction instruction-stream) + (procedure offset instruction) + (loop (instruction-stream))))))) + +(define disassembler/write-constants-block) +(let () + +(set! disassembler/write-constants-block + (named-lambda (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-size block))) + (let loop ((index (compiled-code-block/constants-start block))) + (if (< index end) + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index))))))))) + +(define (write-constant block symbol-table constant) + (write-string (cdr (write-to-string constant 60))) + (if (lambda? constant) + (let ((expression (lambda-body constant))) + (if (and (compiled-code-address? expression) + (eq? (compiled-code-address->block expression) block)) + (begin + (write-string " (") + (let ((offset (compiled-code-address->offset expression))) + (let ((label (disassembler/lookup-symbol symbol-table offset))) + (if label + (write-string (string-downcase label)) + (write offset)))) + (write-string ")")))))) + +) + +(define (disassembler/write-instruction symbol-table offset write-instruction) + (if symbol-table + (sorted-vector/for-each symbol-table offset + (lambda (label) + (write-char #\Tab) + (write-string (string-downcase (label-info-name label))) + (write-char #\:) + (newline)))) + (if disassembler/write-offsets? + (begin (write-string + ((access unparse-number-heuristically number-unparser-package) + offset 16 false false)) + (write-char #\Tab))) + (if symbol-table + (write-string " ")) + (write-instruction) + (newline)) diff --git a/v7/src/compiler/machines/vax/dassm2.scm b/v7/src/compiler/machines/vax/dassm2.scm index 9c4c950d2..70d26d793 100644 --- a/v7/src/compiler/machines/vax/dassm2.scm +++ b/v7/src/compiler/machines/vax/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 1.1 1988/01/07 16:48:17 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.1 1988/01/07 21:16:19 bal Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,240 +32,225 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; VAX Disassembler +;;;; VMS Disassembler: Top Level (declare (usual-integrations)) -(define ((with-info-to-file type receiver) filename) - (let ((filename (->pathname filename))) - (let ((block (file->block (pathname-new-type filename "com")))) - (fluid-let ((*symbol-table)) - (setup-table! (pathname-new-type filename "binf")) - (call-with-output-file (pathname-new-type filename type) - (lambda (port) (receiver block port))))))) +(set! compiled-code-block/bytes-per-object 4) -(define (block-code->port! block port) - (define (instruction-output-string label? instruction) - (let ((string (with-output-to-string - (lambda () - (if label? (format "~%~s:" label?)) - (format "~% ") - (display instruction))))) - (string-downcase! string) - string)) +(set! disassembler/instructions + (lambda (block start-offset end-offset symbol-table) + (let loop ((offset start-offset) (state (disassembler/initial-state))) + (if (and end-offset + (< offset end-offset)) + (disassemble-one-instruction block offset symbol-table state + (lambda (offset* instruction state) + (make-instruction offset + instruction + (lambda () (loop offset* state))))) + '())))) - (let ((last-valid-offset (block-code-ending-offset block))) - (let loop ((offset (block-code-starting-offset block))) - (disassemble-one-instruction block offset - (lambda (new-offset label? instruction) - (write-string (instruction-output-string label? instruction) port) - (and (<= new-offset last-valid-offset) - (loop new-offset))))))) +(set! disassembler/instructions/null? + null?) -(define (block-constants->port! block port) - (define (constant-output-string label? constant) - (with-output-to-string - (lambda () - (if label? - (format "~%~s:" (string-downcase label?))) - (format "~% ~o" constant)))) +(set! disassembler/instructions/read + (lambda (instruction-stream receiver) + (receiver (instruction-offset instruction-stream) + (instruction-instruction instruction-stream) + (instruction-next instruction-stream)))) - (let ((last-valid-index (block-constants-ending-index block))) - (let loop ((index (block-constants-starting-index block))) - (and (<= index last-valid-index) - (let ((offset (block-index->offset index))) - (write-string - (constant-output-string (lookup-label block offset) - (system-vector-ref block index)) - port) - (loop (1+ index))))))) - -(set! compiler:write-lap-file - (with-info-to-file "lap" - (lambda (block port) - (newline port) - (write-string "Executable Code:" port) - (newline port) - (block-code->port! block port) - (newline port) - (newline port) - (write-string "Constants:" port) - (newline port) - (block-constants->port! block port)))) - -(set! compiler:write-constants-file - (with-info-to-file "con" block-constants->port!)) - -(set! disassembly-stream - (named-lambda (disassembly-stream start) - (disassemble-anything start - (lambda (base block offset) - (let ((last-valid-offset (block-code-ending-offset block))) - (let loop ((offset offset)) - (disassemble-one-instruction block offset - (lambda (new-offset label? instruction) - (if (> new-offset last-valid-offset) - '() - ;; INSTRUCTION-STREAM-CONS - (cons (make-instruction offset label? instruction) - (delay (loop new-offset)))))))))))) - -(define (disassemble-anything thing continuation) - (cond ((compiled-code-address? thing) - (let ((block (compiled-code-address->block thing))) - (continuation (primitive-datum block) - block - (compiled-code-address->offset thing)))) - ((integer? thing) - (continuation 0 0 thing)) - (else - (error "Unknown entry to disassemble" thing)))) - -(define (make-address base offset label?) - (or label? offset)) +(define-structure (instruction (type vector)) + (offset false read-only true) + (instruction false read-only true) + (next false read-only true)) (define *block) (define *current-offset) +(define *symbol-table) +(define *ir) (define *valid?) -(define (disassemble-one-instruction block offset receiver) - (define (make-losing-instruction *ir size) - (case size - ((B) - `(DC B ,(bit-string->unsigned-integer *ir))) - ((W) - `(DC W ,(bit-string->unsigned-integer - (bit-string-append *ir (get-byte))))) - ((L) - `(DC L ,(bit-string->unsigned-integer - (bit-string-append (bit-string-append *ir (get-byte)) - (get-word))))))) - +(define (disassemble-one-instruction block offset symbol-table state receiver) (fluid-let ((*block block) (*current-offset offset) + (*symbol-table symbol-table) + (*ir) (*valid? true)) - (receiver *current-offset - (lookup-label block offset) - (let ((size (dcw? block offset)) - (byte (get-byte))) - (if size - (make-losing-instruction byte size) - (let ((instruction - ((vector-ref - opcode-dispatch - (bit-string->unsigned-integer byte))))) - (if *valid? - instruction - (make-losing-instruction byte 'B)))))))) + (set! *ir (get-word)) + (let ((instruction + (if (external-label-marker? symbol-table offset state) + (make-dc 'W *ir) + (let ((instruction + (((vector-ref opcode-dispatch (extract *ir 12 16)))))) + (if *valid? + instruction + (make-dc 'W *ir)))))) + (receiver *current-offset + instruction + (disassembler/next-state instruction state))))) + +(define (disassembler/initial-state) + 'INSTRUCTION-NEXT) -(define (undefined-instruction) - ;; This losing assignment removes a 'call/cc'. Too bad. - (set! *valid? false) - '()) +(define (disassembler/next-state instruction state) + (if (and disassembler/compiled-code-heuristics? + (or (memq (car instruction) '(BR JMP RSB)) + (and (eq? (car instruction) 'JSB) + (let ((entry + (interpreter-register? (cadr instruction)))) + (and entry + (eq? (car entry) 'ENTRY) + (not (eq? (cadr entry) 'SETUP-LEXPR))))))) + 'EXTERNAL-LABEL + 'INSTRUCTION)) + +(set! disassembler/lookup-symbol + (lambda (symbol-table offset) + (and symbol-table + (let ((label (sorted-vector/find-element symbol-table offset))) + (and label + (label-info-name label)))))) + +(define (external-label-marker? symbol-table offset state) + (if symbol-table + (sorted-vector/there-exists? symbol-table + (+ offset 2) + label-info-external?) + (and *block + (not (eq? state 'INSTRUCTION)) + (let loop ((offset (+ offset 2))) + (let ((contents (read-bits (- offset 2) 16))) + (if (bit-string-clear! contents 0) + (let ((offset + (- offset (bit-string->unsigned-integer contents)))) + (and (positive? offset) + (loop offset))) + (= offset (bit-string->unsigned-integer contents)))))))) + +(define (make-dc wl bit-string) + `(DC ,wl ,(bit-string->unsigned-integer bit-string))) + +(define (read-bits offset size-in-bits) + (let ((word (bit-string-allocate size-in-bits))) + (with-interrupt-mask interrupt-mask-none + (lambda (old) + (read-bits! (if *block + (+ (primitive-datum *block) offset) + offset) + 0 + word))) + word)) ;;;; Compiler specific information +(define (register-maker assignments) + (lambda (mode register) + (list mode + (if disassembler/symbolize-output? + (cdr (assq register assignments)) + register)))) + (define register-assignments - '((10 . FRAME-POINTER) + '((0 . 0) ;serves multiple functions, not handled now + (1 . 1) + (2 . 2) + (3 . 3) + (4 . 4) + (5 . 5) + (6 . 6) + (7 . 7) + (8 . 8) + (9 . 9) + (10 . FRAME-POINTER) (11 . REFERENCE-MASK) - (12 . FREE) - (13 . REGS) - (14 . SP) + (12 . FREE-POINTER) + (13 . REGS-POINTER) + (14 . STACK-POINTER) (15 . PC))) - -(define interpreter-register-assignments - (let-syntax () - (define-macro (make-table) - (define (make-entries index names) - (if (null? names) - '() - (cons `(,index . (ENTRY ,(car names))) - (make-entries (+ index 6) (cdr names))))) - `'(;; Interpreter registers - (0 . (REG MEMORY-TOP)) - (4 . (REG STACK-GUARD)) - (8 . (REG VALUE)) - (12 . (REG ENVIRONMENT)) - (16 . (REG TEMPORARY)) - (20 . (REG INTERPRETER-CALL-RESULT:ENCLOSE)) - ;; Interpreter entry points - ,@(make-entries - #x00F0 - '(return-to-interpreter uuo-link-trap apply error - wrong-number-of-arguments interrupt-procedure - interrupt-continuation lookup-apply lookup access unassigned? - unbound? set! define primitive-apply setup-lexpr - safe-lookup cache-variable reference-trap assignment-trap uuo-link - cache-reference-apply safe-reference-trap unassigned?-trap - cache-variable-multiple uuo-link-multiple)))) - (make-table))) -(define-integrable (lookup-special-register reg table) - (assq reg table)) - -(define-integrable (special-register reg-pair) - (cdr reg-pair)) +(set! make-register-offset + (lambda (register offset) + (if disassembler/symbolize-output? + (or (and (= register interpreter-register-pointer) + (let ((entry (assq offset interpreter-register-assignments))) + (and entry + (cdr entry)))) + `(@RO ,(cdr (assq register register-assignments)) + ,offset)) + `(@RO ,register ,offset)))) -(define (make-register register) - (let ((special (and disassembler:symbolize-output? - (lookup-special-register register register-assignments)))) - (if special - (special-register special) - register))) +(set! interpreter-register? + (lambda (effective-address) + (case (car effective-address) + ((@RO) + (and (= (cadr effective-address) interpreter-register-pointer) + (let ((entry + (assq (caddr effective-address) + interpreter-register-assignments))) + (and entry + (cdr entry))))) + ((REGISTER TEMPORARY ENTRY) effective-address) + (else false)))) + +(define interpreter-register-pointer + 6) -(define (make-offset deferred? register size offset) - (let ((key (if deferred? '@@RO '@RO))) - (if (not disassembler:symbolize-output?) - `(,key ,size ,register ,offset) - (let ((special - (lookup-special-register register register-assignments))) - (if special - (if (eq? (special-register special) 'REGS) - (let ((interpreter-register - (lookup-special-register offset - interpreter-register-assignments))) - (cond ((not interpreter-register) - `(,key ,size REGS ,offset)) - ((not deferred?) - (special-register interpreter-register)) - (else - `(@ ,(special-register interpreter-register))))) - `(,key ,size ,(special-register special) ,offset)) - `(,key ,size ,register ,offset)))))) +(define interpreter-register-assignments + (let () + (define (make-entries index names) + (if (null? names) + '() + (cons `(,index . (ENTRY ,(car names))) + (make-entries (+ index 6) (cdr names))))) + `(;; Interpreter registers + (0 . (REGISTER MEMORY-TOP)) + (4 . (REGISTER STACK-GUARD)) + (8 . (REGISTER VALUE)) + (12 . (REGISTER ENVIRONMENT)) + (16 . (REGISTER TEMPORARY)) + (20 . (REGISTER INTERPRETER-CALL-RESULT:ENCLOSE)) + ;; Compiler temporaries + ,@(let loop ((index 40) (i 0)) + (if (= i 50) + '() + (cons `(,index . (TEMPORARY ,i)) + (loop (+ index 4) (1+ i))))) + ;; Interpreter entry points + ,@(make-entries + #x00F0 + '(apply error wrong-number-of-arguments + interrupt-procedure interrupt-continuation + lookup-apply lookup access unassigned? unbound? set! + define primitive-apply enclose setup-lexpr + return-to-interpreter safe-lookup cache-variable + reference-trap assignment-trap)) + ,@(make-entries + #x0228 + '(uuo-link uuo-link-trap cache-reference-apply + safe-reference-trap unassigned?-trap + cache-variable-multiple uuo-link-multiple + &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? + negative? cache-assignment cache-assignment-multiple + operator-trap))))) -(define (make-pc-relative deferred? size pco) - ;; This assumes that pco was just extracted. - ;; VAX PC relative modes are defined with respect to the pc - ;; immediately after the PC relative field. - (let ((absolute (+ pco *current-offset))) - (if disassembler:symbolize-output? - (let ((answ (lookup-label *block absolute))) - (if answ - `(,(if deferred? '@@PCR '@PCR) ,answ) - `(,(if deferred? '@@PCO '@PCO) ,size ,pco))) - `(,(if deferred? '@@PCO '@PCO) ,size ,pco)))) +) -(define *symbol-table) - -;; Temporary Kludge +(define (make-pc-relative thunk) + (let ((reference-offset *current-offset)) + (let ((pco (thunk))) + (offset->pc-relative pco reference-offset)))) -(set! setup-table! - (named-lambda (setup-table! filename) - (set! *symbol-table - (make-binary-searcher (compiler-info-labels (fasload filename)) - offset/label-info=? - offset/label-infopc-relative pco reference-offset) + (if disassembler/symbolize-output? + `(@PCR ,(let ((absolute (+ pco reference-offset))) + (or (disassembler/lookup-symbol *symbol-table absolute) + absolute))) + `(@PCO ,pco))) -(define (lookup-label block offset) - (and (not (unassigned? *symbol-table)) - (let ((label (*symbol-table offset))) - (and label - (label-info-name label))))) +(define (undefined-instruction) + ;; This losing assignment removes a 'cwcc'. Too bad. + (set! *valid? false) + '()) -(define (dcw? block offset) - (and (not (unassigned? *symbol-table)) - (let ((label (*symbol-table (+ offset 2)))) - (and label - (label-info-external? label) - 'W)))) \ No newline at end of file +(define (undefined) + undefined-instruction) diff --git a/v7/src/compiler/machines/vax/machin.scm b/v7/src/compiler/machines/vax/machin.scm index bfa197ea2..ea77fa3b8 100644 --- a/v7/src/compiler/machines/vax/machin.scm +++ b/v7/src/compiler/machines/vax/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 1.1 1988/01/07 21:07:15 bal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/machin.scm,v 4.1 1988/01/07 21:14:55 bal Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,10 +35,7 @@ MIT in each case. |# ;;;; Machine Model for DEC Vax (declare (usual-integrations)) - (define (rtl:message-receiver-size:closure) 1) -(define (rtl:message-receiver-size:stack) 1) -(define (rtl:message-receiver-size:subproblem) 2) - + (define-integrable (stack->memory-offset offset) offset) @@ -88,6 +85,41 @@ MIT in each case. |# ;;; Machine registers +(define-integrable interregnum:memory-top 0) +(define-integrable interregnum:stack-guard 1) +(define-integrable interregnum:value 2) +(define-integrable interregnum:environment 3) +(define-integrable interregnum:temporary 4) +(define-integrable interregnum:enclose 5) + +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((FRAME-POINTER) (interpreter-frame-pointer)) + ((STACK-POINTER) (interpreter-stack-pointer)) + ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) interregnum:memory-top) + ((STACK-GUARD) interregnum:stack-guard) + ((VALUE) interregnum:value) + ((ENVIRONMENT) interregnum:environment) + ((TEMPORARY) interregnum:temporary) + ((INTERPRETER-CALL-RESULT:ENCLOSE) interregnum:enclose) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + (define-integrable r0 0) (define-integrable r1 1) (define-integrable r2 2) @@ -109,6 +141,9 @@ MIT in each case. |# (define-integrable (register-contains-address? register) (memv register '(10 12 13 14 15))) +(define initial-address-registers + (list r10 r12 r13 r14 r15)) + (define-integrable regnum:frame-pointer r10) (define-integrable regnum:free-pointer r12) (define-integrable regnum:regs-pointer r13) @@ -120,45 +155,12 @@ MIT in each case. |# (define available-machine-registers (list r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10)) -(define (pseudo-register=? x y) +(define-integrable (pseudo-register=? x y) (= (register-renumber x) (register-renumber y))) ;;; Interpreter registers -(define-integrable interregnum:memory-top 0) -(define-integrable interregnum:stack-guard 1) -(define-integrable interregnum:value 2) -(define-integrable interregnum:environment 3) -(define-integrable interregnum:temporary 4) -(define-integrable interregnum:enclose 5) - -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((FRAME-POINTER) (interpreter-frame-pointer)) - ((STACK-POINTER) (interpreter-stack-pointer)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) - (interpreter-register:cache-reference)) - ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) - (interpreter-register:cache-unassigned?)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY-TOP) interregnum:memory-top) - ((STACK-GUARD) interregnum:stack-guard) - ((VALUE) interregnum:value) - ((ENVIRONMENT) interregnum:environment) - ((TEMPORARY) interregnum:temporary) - ((INTERPRETER-CALL-RESULT:ENCLOSE) interregnum:enclose) - (else false))) - -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) (define (register-type register) 'GENERAL) @@ -223,4 +225,4 @@ MIT in each case. |# (define lap:make-label-statement) (define lap:make-unconditional-branch) -(define lap:make-entry-point) \ No newline at end of file +(define lap:make-entry-point) -- 2.25.1