#| -*-Scheme-*-

$Id: dassm2.scm,v 4.17 2003/02/14 18:28:07 cph Exp $

Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; VAX Disassembler: Top Level
;;; package: (compiler disassembler)

(declare (usual-integrations))

(define (disassembler/read-variable-cache block index)
  (let-syntax ((ucode-type
		(sc-macro-transformer
		 (lambda (form environment)
		   environment
		   (apply microcode-type (cdr form)))))
	       (ucode-primitive
		(sc-macro-transformer
		 (lambda (form environment)
		   environment
		   (apply make-primitive-procedure (cdr form))))))
    ((ucode-primitive primitive-object-set-type 2)
     (ucode-type quad)
     (system-vector-ref block index))))

(define (disassembler/read-procedure-cache block index)
  (fluid-let ((*block block))
    (let* ((offset (compiled-code-block/index->offset index))
	   (opcode (read-unsigned-integer (+ offset 2) 16)))
      (case opcode
	((#x9f17)			; JMP @&<value>
	 ;; This should learn to decode trampolines.
	 (vector 'COMPILED
		 (read-procedure (+ offset 4))
		 (read-unsigned-integer offset 16)))
	(else
	 (error "disassembler/read-procedure-cache: Unknown opcode"
		opcode block index))))))

(define (disassembler/instructions 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)))))
	'())))

(define (disassembler/instructions/null? obj)
  (null? obj))

(define (disassembler/instructions/read instruction-stream receiver)
  (receiver (instruction-offset instruction-stream)
	    (instruction-instruction instruction-stream)
	    (instruction-next instruction-stream)))

(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 *valid?)

(define (disassemble-one-instruction block offset symbol-table state receiver)
  (define (instruction-end instruction state)
    (let ((next-state (disassembler/next-state instruction state)))
      (receiver *current-offset instruction next-state)))

  (fluid-let ((*block block)
	      (*current-offset offset)
	      (*symbol-table symbol-table)
	      (*valid? true))
    (let* ((byte (get-byte))
	   (start-offset *current-offset))
      ;; External label markers come in two parts:
      ;; An entry type descriptor, and a gc offset.
      (if (or (eq? state 'EXTERNAL-LABEL)
	      (eq? state 'EXTERNAL-LABEL-OFFSET)
	      (external-label-marker? symbol-table offset state))
	  (instruction-end (make-data-deposit byte 'W)
			   (if (eq? state 'EXTERNAL-LABEL-OFFSET)
			       state
			       'EXTERNAL-LABEL))
	  (let ((instruction
		 ((vector-ref
		   opcode-dispatch
		   (bit-string->unsigned-integer byte)))))
	    (if *valid?
		(instruction-end instruction state)
		(begin
		  (set! *current-offset start-offset)
		  (instruction-end
		   (make-data-deposit
		    byte
		    (if disassembler/compiled-code-heuristics?
			'W
			'B))
		   'UNKNOWN))))))))

(define (disassembler/initial-state)
  'INSTRUCTION)

(define (disassembler/next-state instruction state)
  (define (check delta state get-word)
    (let ((offset *current-offset))
      (let* ((next (bit-string->unsigned-integer (get-word)))
	     (result
	      (if (= (+ offset delta) (/ next 2))
		  state
		  'INSTRUCTION)))
	(set! *current-offset offset)
	result)))

  (cond ((or (not disassembler/compiled-code-heuristics?)
	     (eq? state 'EXTERNAL-LABEL-OFFSET))
	 'INSTRUCTION)
	((and (eq? state 'INSTRUCTION)
	      (or (memq (car instruction) '(BR JMP RSB))
		  (and (eq? (car instruction) 'JSB)
		       (let ((entry
			      (interpreter-register?
			       (cadr instruction))))
			 (and entry
			      (eq? (car entry) 'ENTRY))))))
	 (check 4 'EXTERNAL-LABEL (lambda () (get-word) (get-word))))
	((eq? state 'EXTERNAL-LABEL)
	 'EXTERNAL-LABEL-OFFSET)
	((eq? state 'UNKNOWN)
	 (check 2 'EXTERNAL-LABEL-OFFSET get-word))
	(else
	 'INSTRUCTION)))

(define (disassembler/lookup-symbol symbol-table offset)
  (and symbol-table
       (let ((label (dbg-labels/find-offset symbol-table offset)))
	 (and label 
	      (dbg-label/name label)))))

(define (external-label-marker? symbol-table offset state)
  (if symbol-table
      (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
	(and label
	     (dbg-label/external? label)))
      (and *block
	   (not (eq? state 'INSTRUCTION))
	   (let loop ((offset (+ offset 4)))
	     (let ((contents (read-bits (- offset 2) 16)))
	       (if (bit-string-clear! contents 0)
		   (let ((offset
			  (- offset
			     (/ (bit-string->unsigned-integer contents) 2))))
		     (and (positive? offset)
			  (loop offset)))
		   (= offset
		      (/ (bit-string->unsigned-integer contents) 2))))))))

(define (make-data-deposit *ir size)
  (case size
    ((B)
     `(BYTE U ,(bit-string->unsigned-integer *ir)))
    ((W)
     `(WORD U ,(bit-string->unsigned-integer
		(bit-string-append *ir (get-byte)))))
    ((L)
     `(LONG U ,(bit-string->unsigned-integer
		(bit-string-append (bit-string-append *ir (get-byte))
				   (get-word)))))))
  
(define (read-procedure offset)
  (with-absolutely-no-interrupts
   (lambda ()
     (let-syntax ((ucode-type
		   (sc-macro-transformer
		    (lambda (form environment)
		      environment
		      (apply microcode-type (cdr form)))))
		  (ucode-primitive
		   (sc-macro-transformer
		    (lambda (form environment)
		      environment
		      (apply make-primitive-procedure (cdr form))))))
       ((ucode-primitive primitive-object-set-type 2)
	(ucode-type compiled-entry)
	((ucode-primitive make-non-pointer-object 1)
	 (read-unsigned-integer offset 32)))))))

(define (read-unsigned-integer offset size)
  (bit-string->unsigned-integer (read-bits offset size)))

(define (read-bits offset size-in-bits)
  (let ((word (bit-string-allocate size-in-bits))
	(bit-offset (* offset addressing-granularity)))
    (with-absolutely-no-interrupts
     (lambda ()
       (if *block
	   (read-bits! *block bit-offset word)
	   (read-bits! offset 0 word))))
    word))

;;;; Compiler specific information

(define-integrable (lookup-special-register reg table)
  (assq reg table))

(define-integrable (special-register reg-pair)
  (cdr reg-pair))

(define (make-register register)
  (let ((special (and disassembler/symbolize-output?
		      (assq register register-assignments))))
    (if special
	(cdr special)
	register)))

(define register-assignments
  '((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 . DYNAMIC-LINK)
    (11 . REFERENCE-MASK)
    (12 . FREE-POINTER)
    (13 . REGS-POINTER)
    (14 . STACK-POINTER)
    (15 . PROGRAM-COUNTER)))

(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-POINTER)
		  (let ((interpreter-register
			 (lookup-special-register offset 
						  interpreter-register-assignments)))
		    (cond ((not interpreter-register)
			   `(,key ,size REGS-POINTER ,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?
  (lambda (effective-address)
    (case (car effective-address)
      ((@RO)
       (and (eq? (caddr effective-address) 'REGS-POINTER)
	    (let ((entry
		   (assq (cadddr effective-address)
			 interpreter-register-assignments)))
	      (and entry
		   (cdr entry)))))
      ((REGISTER TEMPORARY ENTRY) effective-address)
      (else false))))

(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 INT-MASK))
      (8  . (REGISTER VALUE))
      (12 . (REGISTER ENVIRONMENT))
      (16 . (REGISTER TEMPORARY))
      (20 . (REGISTER INTERPRETER-CALL-RESULT:ENCLOSE))
      (24 . (REGISTER RETURN-CODE))
      (28 . (REGISTER LEXPR-PRIMITIVE-ACTUALS))
      (32 . (REGISTER MINIMUM-LENGTH))
      (36 . (REGISTER PRIMITIVE))
      (44 . (REGISTER STACK-GUARD))
      ;; Interface entry points
      ,@(make-entries
	 #x0280
	 '(link error apply
		lexpr-apply primitive-apply primitive-lexpr-apply
		cache-reference-apply lookup-apply
		interrupt-continuation interrupt-ic-procedure
		interrupt-procedure interrupt-closure
		lookup safe-lookup set! access unassigned? unbound? define
		reference-trap safe-reference-trap assignment-trap
		unassigned?-trap
		&+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
      ;; Compiler temporaries
      ,@(let loop ((index -4) (i 0))
	  (if (>= i 512)
	      '()
	      (cons `(,index . (TEMPORARY ,i))
		    (loop (- index 4) (1+ i))))))))


(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.

  (define (default)
    `(,(if deferred? '@@PCO '@PCO) ,size ,pco))

  (define (test address)
    (disassembler/lookup-symbol *symbol-table address))

  (define (object-offset? relative)
    (let* ((unsigned (if (negative? relative)
			 (+ (expt 2 32) relative)
			 relative))
	   (tc (quotient unsigned (expt 2 scheme-datum-width))))

      (define (try tc)
	(let* ((object-base (* tc (expt 2 scheme-datum-width)))
	       (offset (- unsigned object-base)))
	  (cond ((test (+ *current-offset offset))
		 =>
		 (lambda (label)
		   (list label object-base)))
		(else
		 false))))

      (or (try tc)
	  (try (1+ tc)))))

  (let ((absolute (+ pco *current-offset)))
    (cond ((not disassembler/symbolize-output?)
	   (default))
	  ((test absolute)
	   =>
	   (lambda (answ)
	     `(,(if deferred? '@@PCR '@PCR) ,answ)))
	  ((test (- absolute 2))
	   ;; Kludge to get branches to execute caches correctly.
	   =>
	   (lambda (answ)
	     `(,(if deferred? '@@PCRO '@PCRO) ,answ 2)))
	  ((object-offset? pco)
	   =>
	   (lambda (answ)
	     `(,(if deferred? '@@PCRO '@PCRO) ,@answ)))
	  (else
	   (default)))))

(define (undefined-instruction)
  ;; This losing assignment removes a 'cwcc'. Too bad.
  (set! *valid? false)
  '())

(define (undefined)
  undefined-instruction)

(define compiled-code-block/procedure-cache-offset 0)
(define compiled-code-block/objects-per-procedure-cache 2)
(define compiled-code-block/objects-per-variable-cache 1)

;; global variable used by runtime/udata.scm -- Moby yuck!

(set! compiled-code-block/bytes-per-object 4)
