#| -*-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
MIT in each case. |#
;;;; VAX Disassembler
+;;;
+;;; Matches version 4.2 of bobcat/dassm1.scm
+;;;
(declare (usual-integrations))
\f
-(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 <head> (delay <tail>))
-
-(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))
+\f
+(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)))))))
+\f
+(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))
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; VAX Disassembler
+;;;; VMS Disassembler: Top Level
(declare (usual-integrations))
\f
-(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)))))))
-\f
-(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))))
-\f
-(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)))))
+\f
+(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))
\f
;;;; 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)))
\f
-(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))))
+\f
+(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))))
+)
\f
-(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-info<?))
- *symbol-table))
+(define (offset->pc-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)
#| -*-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
;;;; Machine Model for DEC Vax
(declare (usual-integrations))
-\f(define (rtl:message-receiver-size:closure) 1)
-(define (rtl:message-receiver-size:stack) 1)
-(define (rtl:message-receiver-size:subproblem) 2)
-
+\f
(define-integrable (stack->memory-offset offset)
offset)
\f
;;; 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)
(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)
(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)
-\f
-(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)))
\f
(define (register-type register)
'GENERAL)
(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)
projects / mit-scheme.git / commitdiff