Commit edac2d80 authored by cvs2git's avatar cvs2git
Browse files

This commit was manufactured by cvs2svn to create branch 'new_struct'.

parent 10b7c474
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; The DISASSEMBLE function as described in the Common Lisp manual.
;;;
;;; Written by Don Mathis
;;;
;;;
;;; Modified 11/83 by Robert Rose to put an asterisk before lines
;;; that are branched to.
;;;
;;; Heavily Modified 1/84 to use new instruction set.
;;;
;;; Modified by David B. McDonald to disassemble the Romp instruction
;;; set.
;;;
;;; Hacked by Rob MacLachlan for the interim RT function format. Hopefully
;;; this file will die after the port.
;;;
;;; **********************************************************************
;;;
(in-package 'compiler :use '("LISP" "SYSTEM"))
(export 'lisp::disassemble (find-package 'lisp))
(proclaim '(special romp-4bit-opcode-symbol romp-8bit-opcode-symbol))
;;;; The Main function, DISASSEMBLE
(defun disassemble (function &optional (*standard-output* *standard-output*))
"The argument should be either a function object, a lambda expression, or
a symbol with a function definition. If the relevant function is not a
compiled function, it is first compiled. In any case, the compiled code
is then 'reverse assembled' and printed out in a symbolic format."
(etypecase function
(function
(ecase (%primitive get-vector-subtype function)
((#.%function-entry-subtype #.%function-closure-entry-subtype)
(prin-prelim-info function)
(Output-macro-instructions function (branch-list function)))
(#.%function-closure-subtype
(disassemble (%primitive header-ref function %function-name-slot)))))
(symbol
(disassemble (symbol-function function)))))
;;; PRIN-PRELIM-INFO takes a function object and extracts from it and
;;; prints out the following information:
;;; - The argument list of the function.
;;; - The number of Locals allocated by the function.
;;; - Whether the function does or does not evaluate its arguments.
(defun prin-prelim-info (function)
(format t "~%Disassembly of ~S.~%"
(%primitive header-ref function %function-name-slot))
(format t "~%Its arg list is: ~A.~%"
(%primitive header-ref function %function-entry-arglist-slot)))
;;; OUTPUT-MACRO-INSTRUCTIONS takes a function object and prints out the
;;; corresponding macro. (Not executable macro, just macro that looks good!)
(defun Output-Macro-Instructions (function branches)
(declare (optimize (speed 3) (safety 0)))
(let* ((byte-vector
(%primitive header-ref function %function-code-slot))
(offset
(- (%primitive header-ref function %function-offset-slot)
i-vector-header-size))
(vector-length (length byte-vector)))
(declare (fixnum vector-length))
(do ((i 0))
((= i vector-length))
(declare (fixnum i))
(when (= i offset)
(format t "~&*** Enter here:~%"))
(let* ((opcode (aref byte-vector i))
(symbol (find-symbol-name opcode))
(inst-type (get symbol 'romp-instruction-type)))
(case inst-type
(ji (print-ji-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(x (print-x-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(ds (print-ds-instruction opcode byte-vector i branches function)
(setq i (the fixnum (+ i 2))))
(r (print-r-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 2))))
(bi (print-bi-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 4))))
(ba (print-ba-instruction opcode byte-vector i branches)
(setq i (the fixnum (+ i 4))))
(d (setq i (the fixnum
(+ i (the fixnum
(print-d-instruction opcode byte-vector i
branches function ))))))
(T (error "Illegal instruction type: ~A for instruction ~A.~%"
inst-type symbol)))))))
(defun find-symbol-name (opcode)
(declare (fixnum opcode))
(let ((symbol (svref romp-4bit-opcode-symbol (logand (the fixnum (ash opcode -4)) #xFF))))
(if symbol
symbol
(svref romp-8bit-opcode-symbol opcode))))
;;; BRANCH-LIST is very much like output-macro-instructions,
;;; but instead of actually creating all the instructions it just
;;; creates the branch instruction labels. A list of these labels
;;; is returned.
(defun branch-list (function)
(let* ((byte-vector
(%primitive header-ref function %function-code-slot))
(vector-length (length byte-vector))
(branches nil))
(declare (fixnum vector-length))
(do ((i 0))
((>= i vector-length))
(declare (fixnum i))
(let* ((opcode (aref byte-vector i))
(symbol (find-symbol-name opcode))
(inst-type (get symbol 'romp-instruction-type)))
(case inst-type
(ji (push (the fixnum (+ i (the fixnum (sign-extend-ji byte-vector i)))) branches)
(setq i (the fixnum (+ i 2))))
((x ds r) (setq i (the fixnum (+ i 2))))
(bi (push (the fixnum (+ i (the fixnum (sign-extend-bi byte-vector i)))) branches)
(setq i (the fixnum (+ i 4))))
((ba d) (setq i (the fixnum (+ i 4))))
(T (error "Unknown instruction type: ~A, for instruction ~A.~%"
inst-type symbol)))))
branches))
(defun print-ji-instruction (opcode byte-vector index branches)
(declare (fixnum opcode index))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(if (= (logand opcode #x8) 0) "JNB" "JB")
(romp-condition-code (+ 8 (logand opcode #x7)))
`(**address** ,(the fixnum (+ index (the fixnum (sign-extend-ji byte-vector index)))))))
(defun print-x-instruction (opcode byte-vector index branches)
(declare (fixnum opcode index))
(let* ((rega (get-register-name (logand opcode #xF)))
(operand (aref byte-vector (the fixnum (1+ index))))
(regb (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regc (get-register-name (logand operand #xF)))
(star (if (memq index branches) "*" " ")))
(declare (fixnum operand))
(if (eq regc 'NL0)
(cond ((and (eq rega 'NL0) (eq regb 'NL0))
(format t "~6D~A (LR NL0 NL0) ; Padding for previous execute instruction.~%"
index star))
(T (format t "~6D~A (LR ~A ~A)~%"
index (if (memq index branches) "*" " ")
rega regb)))
(format t "~6D~A (CAS ~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
rega regb regc))))
(defun print-ds-instruction (opcode byte-vector index branches function)
(declare (fixnum opcode index))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regb (get-register-name (logand operand #xF)))
(offset (ash (logand opcode #xF) 2)))
(declare (fixnum offset operand))
(cond ((and (memq symbol '(ls sts))
(memq regb '(ENV CONT)))
(print-special-access symbol rega regb offset function
index branches))
(T (format t "~6D~A (~A ~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name (logand (the fixnum (ash operand -4)) #xF))
(get-register-name (logand operand #xF))
(case symbol
((ls sts) (ash (logand opcode #xF) 2))
((lhs lhas sths) (ash (logand opcode #xF) 1))
(T (logand opcode #xF))))))))
(defun print-r-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (logand (the fixnum (ash operand -4)) #xF))
(regb (logand operand #xF)))
(declare (fixnum operand))
(cond ((memq symbol '(inc dec lis mftbil mftbiu mttbil mttbiu
ais cis sis clrbl clrbu setbl setbu
sari sari16 sri sri16 srpi srpi16
sli sli16 slpi slpi16))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name rega)
regb))
((memq symbol '(bbr bbrx bnbr bnbrx))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(romp-condition-code rega)
(get-register-name regb)))
((memq symbol '(mts mfs))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb))
((memq symbol '(clrsb setsb))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb))
(T (format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
(get-register-name rega)
(get-register-name regb))))))
(defun print-bi-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(cc (romp-condition-code
(logand (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) -4) #xF)))
(label (the fixnum (+ index (the fixnum (sign-extend-bi byte-vector index))))))
(format t "~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol) cc `(**address** ,label))))
(defun print-ba-instruction (opcode byte-vector index branches)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (the fixnum (logior (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) 16)
(ash (the fixnum (aref byte-vector (the fixnum (+ index 2)))) 8)
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(miscop (find-miscop-name operand)))
(format t "~6D~A (~A ~A) ; Call miscop ~A.~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
miscop
miscop))
4)
(defun print-d-instruction (opcode byte-vector index branches function)
(declare (fixnum index opcode))
(let* ((symbol (find-symbol-name opcode))
(operand (aref byte-vector (the fixnum (1+ index))))
(rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
(regb (get-register-name (logand operand #xF)))
(offset (sign-extend-d byte-vector index)))
(declare (fixnum offset operand))
(cond ((eq symbol 'ci)
(format t"~6D~A (~A ~A ~A)~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega offset)
4)
((and (memq symbol '(l st))
(memq regb '(ENV CONT)))
(print-special-access symbol rega regb offset function
index branches)
4)
(T (format t "~6D~A (~A ~A ~A ~A)~A~%"
index (if (memq index branches) "*" " ")
(symbol-name symbol)
rega regb offset
(if (eq (setq offset (logand offset #xFFFF)) nil-16)
" ; NIL."
(if (eq offset t-16)
" ; T."
"")))
4))))
(defun print-special-access (symbol rega regb offset function index branches)
(declare (fixnum index offset))
(let ((star (if (memq index branches) "*" " "))
(*print-level* 3)
(*print-length* 10))
(cond
((not (eq regb 'ENV))
(format t "~6D~A (~A ~A ~A ~A) ; Stack slot ~D.~%"
index star (symbol-name symbol)
rega regb offset
(ash offset -2)))
((= offset (ash %function-code-slot 2))
(format t "~6D~A (~A ~A ~A ~A) ; Function code.~%"
index star (symbol-name symbol)
rega regb offset))
((= offset (ash %function-offset-slot 2))
(format t "~6D~A (~A ~A ~A ~A) ; Function offset.~%"
index star (symbol-name symbol)
rega regb offset))
(t
(format t "~6D~A (~A ~A ~A ~A) ; Constant: ~S.~%"
index star (symbol-name symbol)
rega regb offset
(%primitive header-ref
(%primitive header-ref function
%function-entry-constants-slot)
(ash (the fixnum
(- offset g-vector-header-size)) -2)))))))
(defun sign-extend-ji (byte-vector index)
(declare (fixnum index))
(let ((byte (aref byte-vector (the fixnum (1+ index)))))
(declare (fixnum byte))
(ash (if (= (logand byte #x80) 0)
byte
(the fixnum (- (the fixnum (1+ (logand (lognot byte) #x7F))))))
1)))
(defun sign-extend-bi (byte-vector index)
(declare (fixnum index))
(let ((int (logior (the fixnum (ash (logand (the fixnum (aref byte-vector (the fixnum (1+ index)))) #xF) 16))
(the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(declare (fixnum int))
(ash (if (= (logand int #x80000) 0)
int
(the fixnum (- (the fixnum (1+ (logand (lognot int) #x7FFFF))))))
1)))
(defun sign-extend-d (byte-vector index)
(declare (fixnum index))
(let ((hword (logior (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
(the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
(declare (fixnum hword))
(if (= (logand hword #x8000) 0)
hword
(the fixnum (- (the fixnum (1+ (logand (lognot hword) #xFFFF))))))))
(defun romp-condition-code (cc)
(if (<= 8 cc 16)
(svref '#(pz lt eq gt cz reserved ov tb) (- cc 8))
'??))
(defun get-register-name (reg)
(svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4 BS CONT ENV PC) reg))
(defvar miscop-cache NIL)
(defun find-miscop-name (index)
(if (null miscop-cache) (initialize-miscop-cache))
(gethash index miscop-cache))
(defun initialize-miscop-cache ()
(setq miscop-cache (make-hash-table :size 500))
(do-symbols (x (find-package "CLC"))
(let ((v (get x 'lisp::%loaded-address)))
(when v
(setf (gethash v miscop-cache) x))))
(dolist (x lisp::*user-defined-miscops*)
(setf (gethash (get x 'lisp::%loaded-address) miscop-cache) x)))
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
(in-package 'compiler)
(export '(asm asm-files) (find-package 'compiler))
(defun asm (f)
(assemble-file (concatenate 'simple-string "miscops:" f ".romp")))
(defun asm-files ()
(asm "abs")
(asm "allocation")
(asm "arith")
(asm "array")
(asm "byte")
(asm "call")
(asm "nlx")
(asm "compare")
(asm "divide")
(asm "gc")
(asm "gcd")
(asm "irrat")
(asm "list")
(asm "logic")
(asm "minus")
(asm "misc")
(asm "multiply")
(asm "negate")
(asm "plus")
(asm "print")
(asm "predicate")
(asm "save")
(asm "stack")
(asm "symbol")
(asm "system")
(asm "truncate"))
This diff is collapsed.
;;; -*- Mode: Lisp; Package: Compiler -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This file defines the instruction set for the Common Lisp Romp Assembler
;;; used by the compiler.
;;; Written by David B. McDonald.
(in-package 'Compiler)
(defvar romp-4bit-opcode-symbol (make-array 16))
(defvar romp-8bit-opcode-symbol (make-array 256))
;;; Define-Romp-Instruction defines a Romp instruction to the assembler.
;;; It accepts three arguments:
;;; romp-instruction is a symbol whose pname is the name of a Romp instruction
;;; romp-inst-type specifies the underlying type of the Romp instruction.
;;; it must have one of the following values: JI, X, DS, R, BI, BA,
;;; or D.
;;; romp-code specifies the numeric op code for the instruction.
(defmacro Define-Romp-Instruction (romp-instruction romp-inst-type romp-code)
`(progn (setf (get ',romp-instruction 'romp-instruction-type)
',romp-inst-type)
(setf (get ',romp-instruction 'romp-operation-code)
,romp-code)
,(case romp-inst-type
(ji
`(setf (svref romp-4bit-opcode-symbol 0) ',romp-instruction))
((x ds)
`(setf (svref romp-4bit-opcode-symbol ,romp-code) ',romp-instruction))
((r bi ba d)
`(setf (svref romp-8bit-opcode-symbol ,romp-code) ',romp-instruction))
(T
(error "Illegal instruction type: ~A, for instruction ~A (~A).~%"
romp-inst-type romp-instruction romp-code)))))
;;; Define-Romp-Branch defines a Romp branch instruction to the assembler. It
;;; accepts three arguments:
;;; romp-branch is a symbol whose pname is the name of a branch instruction.
;;; romp-instruction is the underlying romp-instruction that should be used
;;; used to implement the branch instruction.
;;; condition-code specifies the bit of the condition code that should be
;;; be tested to implement the branch.
(defmacro Define-Romp-Branch (romp-branch romp-instruction condition-code)
`(progn (setf (get ',romp-branch 'romp-branch-instruction)
',romp-instruction)
(setf (get ',romp-branch 'romp-condition-code)
,condition-code)))
;;; Define-Condition-Code associates the integer code for a particular condition
;;; code bit with a symbol. It accepts a symbol and a value.
(defmacro Define-Condition-Code (condition-code value)
`(setf (get ',condition-code 'condition-code) ,value))
;;; Storage Access Instructions.
(define-romp-instruction lcs ds #x4)
(define-romp-instruction lc d #xCE)
(define-romp-instruction lhas ds #x5)
(define-romp-instruction lha d #xCA)
(define-romp-instruction lhs r #xEB)
(define-romp-instruction lh d #xDA)
(define-romp-instruction ls ds #x7)
(define-romp-instruction l d #xCD)
(define-romp-instruction lm d #xC9)
(define-romp-instruction tsh d #xCF)
(define-romp-instruction stcs ds #x1)
(define-romp-instruction stc d #xDE)
(define-romp-instruction sths ds #x2)
(define-romp-instruction sth d #xDC)
(define-romp-instruction sts ds #x3)
(define-romp-instruction st d #xDD)
(define-romp-instruction stm d #xD9)
;;; Address Computation Instructions.
(define-romp-instruction cal d #xC8)
(define-romp-instruction cal16 d #xC2)
(define-romp-instruction cau d #xD8)
(define-romp-instruction cas x #x6)
(define-romp-instruction ca16 r #xF3)
(define-romp-instruction inc r #x91)
(define-romp-instruction dec r #x93)
(define-romp-instruction lis r #xA4)
;;; Basic Romp Branch Instructions.
(define-romp-instruction bala ba #x8A)
(define-romp-instruction balax ba #x8B)
(define-romp-instruction bali bi #x8C)
(define-romp-instruction balix bi #x8D)
(define-romp-instruction balr r #xEC)
(define-romp-instruction balrx r #xED)
(define-romp-instruction jb ji #x1)
(define-romp-instruction bb bi #x8E)
(define-romp-instruction bbx bi #x8F)
(define-romp-instruction bbr r #xEE)
(define-romp-instruction bbrx r #xEF)
(define-romp-instruction jnb ji #x0)
(define-romp-instruction bnb bi #x88)
(define-romp-instruction bnbx bi #x89)
(define-romp-instruction bnbr r #xE8)
(define-romp-instruction bnbrx r #xE9)
;;; Romp Trap Instrunctions.
(define-romp-instruction ti d #xCC)
(define-romp-instruction tgte r #xBD)
(define-romp-instruction tlt r #xBE)
;;; Romp Move and Insert Instructions.
(define-romp-instruction mc03 r #xF9)
(define-romp-instruction mc13 r #xFA)
(define-romp-instruction mc23 r #xFB)
(define-romp-instruction mc33 r #xFC)
(define-romp-instruction mc30 r #xFD)
(define-romp-instruction mc31 r #xFE)
(define-romp-instruction mc32 r #xFF)
(define-romp-instruction mftb r #xBC)
(define-romp-instruction mftbil r #x9D)
(define-romp-instruction mftbiu r #x9C)
(define-romp-instruction mttb r #xBF)
(define-romp-instruction mttbil r #x9F)
(define-romp-instruction mttbiu r #x9E)
;;; Romp Arithmetic Instructions.
(define-romp-instruction a r #xE1)
(define-romp-instruction ae r #xF1)
(define-romp-instruction aei d #xD1)
(define-romp-instruction ai d #xC1)
(define-romp-instruction ais r #x90)
(define-romp-instruction abs r #xE0)
(define-romp-instruction onec r #xF4)
(define-romp-instruction twoc r #xE4)
(define-romp-instruction c r #xB4)
(define-romp-instruction cis r #x94)
(define-romp-instruction ci d #xD4)
(define-romp-instruction cl r #xB3)
(define-romp-instruction cli d #xD3)
(define-romp-instruction exts r #xB1)
(define-romp-instruction s r #xE2)
(define-romp-instruction sf r #xB2)
(define-romp-instruction se r #xF2)
(define-romp-instruction sfi d #xD2)
(define-romp-instruction sis r #x92)
(define-romp-instruction d r #xB6)
(define-romp-instruction m r #xE6)
;;; Romp Logical Operations
(define-romp-instruction clrbl r #x99)
(define-romp-instruction clrbu r #x98)
(define-romp-instruction setbl r #x9B)
(define-romp-instruction setbu r #x9A)
(define-romp-instruction n r #xE5)
(define-romp-instruction nilz d #xC5)
(define-romp-instruction nilo d #xC6)
(define-romp-instruction niuz d #xD5)
(define-romp-instruction niuo d #xD6)
(define-romp-instruction o r #xE3)
(define-romp-instruction oil d #xC4)