;;; -*- Lisp -*-
;;;
;;; Instruction definitions for Spice Lisp.
;;; Written by Skef Wholey.
;;;
;;; This file contains information about the instruction set and is
;;; used by the microassembler, the compiler, the error system, and the
;;; disassembler.
;;;
(defvar *1byte-instruction-table*
(make-array 256)
"Table used to find the name of a 1 byte long instruction given its
opcode.")
(defvar *2byte-instruction-table*
(make-array 256)
"Table used to find the name of a 2 byte long instruction given the second
byte of its opcode.")
(defvar *instruction-list* () "List of the instruction names.")
;;; We do this random setq so that the right thing happens when a new
;;; definition file is loaded.
(setq *instruction-list* ())
(defun definstruction (name opcode
&optional (type 'read) (operand 'stack) offset)
"Defines an instruction with the given Name (a symbol) and Opcode.
Opcode may be either a single integer or a list of integers. Type
should be one of Read, Write, Read-Modify-Write, Long-Branch, or
Short-Branch. Operand defaults to Stack. Instructions which don't
really have operands are considered to be Read Stack operations.
Operand should be one of Stack, PSIC, NSIC, AL, Long-AL, Constant,
Long-Constant, Symbol, Long-Symbol, or Ignore. If the instruction has an
implied offset, that should be specified with the Offset."
(if (fixnump opcode)
(setq opcode (list opcode)))
(if (not (listp opcode))
(error "The opcode for ~S must be either an integer or a list." name))
(setf (get name '%instruction-opcode) opcode)
(setf (get name '%instruction-length)
(+ (length opcode)
(cond ((memq type '(read write read-modify-write))
(cond (offset 0)
((memq operand '(stack ignore))
0)
((memq operand '(psic nsic al constant symbol))
1)
((memq operand '(long-al long-constant long-symbol))
2)
(t
(error "~S is a losing operand." operand))))
((memq type '(long-branch-forward long-branch-backward)) 2)
((memq type '(short-branch-forward short-branch-backward)) 1)
((eq type 'long-dispatch) 3)
((eq type 'short-dispatch) 4)
(t (error "~S is a losing type." type)))))
(setf (get name '%instruction-type) type)
(setf (get name '%instruction-operand) operand)
(setf (get name '%instruction-offset) offset)
(push name *instruction-list*)
(if (= (car opcode) 254)
(setf (aref *2byte-instruction-table* (cadr opcode)) name)
(setf (aref *1byte-instruction-table* (car opcode)) name)))
;;; Definstructionclass is used to define a class of instructions, i.e. a
;;; set of instructions that perform the same operation on operands in
;;; different places. Each instruction in the class has its %Instruction-Group
;;; property set to the Stack-Form.
(defun definstructionclass (stack-form &rest other-forms)
(setf (get stack-form '%instruction-class) other-forms)
(do ((forms other-forms (cdr forms)))
((null forms))
(let ((glob (cdar forms)))
(if (listp glob)
(do ((subforms glob (cdr subforms)))
((null subforms))
(setf (get (cdar subforms) '%instruction-group) stack-form))
(setf (get glob '%instruction-group) stack-form)))))
;;; 1Byte generates a definstruction for a one-byte instruction.
(defvar *1byte-instruction-counter* nil
"Counter used to generate unique 1 byte long instructions.")
(defmacro 1byte (name . other-stuff)
"Generates a Definstruction for the Name and Other-Stuff with a unique
one-byte opcode."
`(definstruction ,name ',(prog1 *1byte-instruction-counter*
(incf *1byte-instruction-counter*))
. ,other-stuff))
;;; 2Byte generates a definstruction for a two-byte instruction.
(defvar *2byte-instruction-counter* nil
"Counter used to generate unique 2 byte long instructions.")
(defmacro 2byte (name . other-stuff)
"Generates a Definstruction for the Name and Other-Stuff with a unique
one-byte opcode."
`(definstruction ,name '(254 ,(prog1 *2byte-instruction-counter*
(incf *2byte-instruction-counter*)))
. ,other-stuff))
;;; Set the counts:
(eval-when (compile)
(setq *1byte-instruction-counter* 1)
(setq *2byte-instruction-counter* 0))
;;; InstrSynonym defines a synonym for an instruction.
(defmacro instrsynonym (for is &optional type)
`(progn (setf (get ,is '%instruction-offset)
(get ,for '%instruction-offset))
(setf (get ,is '%instruction-destination)
(get ,for '%instruction-destination))
(setf (get ,is '%instruction-type)
,(or type
`(get ,for '%instruction-type)))
(setf (get ,is '%instruction-length)
(get ,for '%instruction-length))
(setf (get ,is '%instruction-opcode)
(get ,for '%instruction-opcode))))
;;; Allocation:
(2byte 'get-allocation-space)
(2byte 'set-allocation-space)
(2byte 'alloc-bit-vector)
(2byte 'alloc-i-vector)
(2byte 'alloc-string)
(2byte 'alloc-bignum)
(2byte 'float-long)
(2byte 'make-complex)
(2byte 'make-ratio)
(2byte 'alloc-g-vector)
(definstructionclass 'vector
'(psic . vector-psic))
(2byte 'vector)
(2byte 'vector-psic 'read 'psic)
(2byte 'alloc-function)
(2byte 'alloc-array)
(2byte 'alloc-symbol)
(definstructionclass 'cons
'(al . cons-al))
(1byte 'cons)
(1byte 'cons-al 'read 'al)
(definstructionclass 'list
'(psic . ((psic . list-psic)
(1 . list-psic1)
(2 . list-psic2)
(3 . list-psic3))))
(2byte 'list)
(1byte 'list-psic)
(1byte 'list-psic1 'read 'psic 1)
(1byte 'list-psic2 'read 'psic 2)
(1byte 'list-psic3 'read 'psic 3)
(definstructionclass 'list*
'(psic . list*-psic))
(2byte 'list*)
(2byte 'list*-psic 'read 'psic)
;;; Stack manipulation:
(definstructionclass 'push
'(psic . ((psic . push-psic)
(0 . push-psic0)
(1 . push-psic1)
(2 . push-psic2)
(3 . push-psic3)
(4 . push-psic4)
(5 . push-psic5)
(6 . push-psic6)
(7 . push-psic7)
(8 . push-psic8)))
'(nsic . push-nsic)
'(al . ((al . push-al)
(0 . push-al0)
(1 . push-al1)
(2 . push-al2)
(3 . push-al3)
(4 . push-al4)
(5 . push-al5)
(6 . push-al6)
(7 . push-al7)
(8 . push-al8)
(9 . push-al9)
(10 . push-al10)
(11 . push-al11)
(12 . push-al12)
(13 . push-al13)))
'(longal . push-longal)
'(c . ((c . push-c)
(1 . push-c1)
(2 . push-c2)
(3 . push-c3)
(4 . push-c4)
(5 . push-c5)
(6 . push-c6)
(7 . push-c7)
(8 . push-c8)
(9 . push-c9)
(10 . push-c10)
(11 . push-c11)))
'(longc . push-longc)
'(s . push-s)
'(longs . push-longs))
(1byte 'push-psic 'read 'psic)
(1byte 'push-psic0 'read 'psic 0)
(1byte 'push-psic1 'read 'psic 1)
(1byte 'push-psic2 'read 'psic 2)
(1byte 'push-psic3 'read 'psic 3)
(1byte 'push-psic4 'read 'psic 4)
(1byte 'push-psic5 'read 'psic 5)
(1byte 'push-psic6 'read 'psic 6)
(1byte 'push-psic7 'read 'psic 7)
(1byte 'push-psic8 'read 'psic 8)
(1byte 'push-nsic 'read 'nsic)
(1byte 'push-al 'read 'al)
(1byte 'push-al0 'read 'al 0)
(1byte 'push-al1 'read 'al 1)
(1byte 'push-al2 'read 'al 2)
(1byte 'push-al3 'read 'al 3)
(1byte 'push-al4 'read 'al 4)
(1byte 'push-al5 'read 'al 5)
(1byte 'push-al6 'read 'al 6)
(1byte 'push-al7 'read 'al 7)
(1byte 'push-al8 'read 'al 8)
(1byte 'push-al9 'read 'al 9)
(1byte 'push-al10 'read 'al 10)
(1byte 'push-al11 'read 'al 11)
(1byte 'push-al12 'read 'al 12)
(1byte 'push-al13 'read 'al 13)
(2byte 'push-longal 'read 'long-al)
(1byte 'push-c 'read 'constant)
(1byte 'push-c1 'read 'constant 1)
(1byte 'push-c2 'read 'constant 2)
(1byte 'push-c3 'read 'constant 3)
(1byte 'push-c4 'read 'constant 4)
(1byte 'push-c5 'read 'constant 5)
(1byte 'push-c6 'read 'constant 6)
(1byte 'push-c7 'read 'constant 7)
(1byte 'push-c8 'read 'constant 8)
(1byte 'push-c9 'read 'constant 9)
(1byte 'push-c10 'read 'constant 10)
(1byte 'push-c11 'read 'constant 11)
(2byte 'push-longc 'read 'long-constant)
(1byte 'push-s 'read 'symbol)
(2byte 'push-longs 'read 'long-symbol)
(definstructionclass 'pop
'(al . ((al . pop-al)
(0 . pop-al0)
(1 . pop-al1)
(2 . pop-al2)
(3 . pop-al3)
(4 . pop-al4)
(5 . pop-al5)
(6 . pop-al6)
(7 . pop-al7)
(8 . pop-al8)
(9 . pop-al9)))
'(longal . pop-longal)
'(s . pop-s)
'(longs . pop-longs)
'(ignore . pop-ignore))
(1byte 'pop-al 'write 'al)
(1byte 'pop-al0 'write 'al 0)
(1byte 'pop-al1 'write 'al 1)
(1byte 'pop-al2 'write 'al 2)
(1byte 'pop-al3 'write 'al 3)
(1byte 'pop-al4 'write 'al 4)
(1byte 'pop-al5 'write 'al 5)
(1byte 'pop-al6 'write 'al 6)
(1byte 'pop-al7 'write 'al 7)
(1byte 'pop-al8 'write 'al 8)
(1byte 'pop-al9 'write 'al 9)
(2byte 'pop-longal 'write 'long-al)
(1byte 'pop-s 'write 'symbol)
(2byte 'pop-longs 'write 'long-symbol)
(1byte 'pop-ignore 'write 'ignore)
(2byte 'exchange)
(definstructionclass 'copy
'(al . ((al . copy-al)
(1 . copy-al1)
(2 . copy-al2)
(3 . copy-al3)))
'(s . copy-s))
(2byte 'copy 'write)
(1byte 'copy-al 'write 'al)
(1byte 'copy-al1 'write 'al 1)
(1byte 'copy-al2 'write 'al 2)
(1byte 'copy-al3 'write 'al 3)
(1byte 'copy-s 'write 'symbol)
(definstructionclass 'npop
'(nsic . npop-nsic))
(1byte 'npop)
(1byte 'npop-nsic 'write 'nsic)
(definstructionclass 'bind-null
'(c . bind-null-c))
(2byte 'bind-null)
(2byte 'bind-null-c 'read 'constant)
(definstructionclass 'bind
'(c . bind-c))
(2byte 'bind)
(1byte 'bind-c 'read 'constant)
(definstructionclass 'unbind
'(psic . ((psic . unbind-psic)
(1 . unbind-psic1))))
(2byte 'unbind)
(1byte 'unbind-psic 'read 'psic)
(1byte 'unbind-psic1 'read 'psic 1)
;;; List manipulation:
(definstructionclass 'car
'(al . ((al . car-al)
(0 . car-al0)
(1 . car-al1)
(2 . car-al2)
(3 . car-al3)))
'(s . car-s))
(1byte 'car)
(1byte 'car-al 'read 'al)
(1byte 'car-al0 'read 'al 0)
(1byte 'car-al1 'read 'al 1)
(1byte 'car-al2 'read 'al 2)
(1byte 'car-al3 'read 'al 3)
(1byte 'car-s 'read 'symbol)
(definstructionclass 'cdr
'(al . ((al . cdr-al)
(0 . cdr-al0))))
(1byte 'cdr)
(1byte 'cdr-al 'read 'al)
(1byte 'cdr-al0 'read 'al 0)
(definstructionclass 'cadr
'(al . ((al . cadr-al)
(0 . cadr-al0)))
'(s . cadr-s))
(1byte 'cadr)
(1byte 'cadr-al 'read 'al)
(1byte 'cadr-al0 'read 'al 0)
(1byte 'cadr-s 'read 'symbol)
(definstructionclass 'cddr
'(al . cddr-al))
(2byte 'cddr)
(2byte 'cddr-al 'read 'al)
(definstructionclass 'cdar
'(al . cdar-al))
(1byte 'cdar)
(1byte 'cdar-al 'read 'al)
(definstructionclass 'caar
'(al . caar-al))
(1byte 'caar)
(1byte 'caar-al 'read 'al)
(definstructionclass 'set-cdr
'(al . set-cdr-al)
'(s . set-cdr-s))
(1byte 'set-cdr-al 'read-modify-write 'al)
(1byte 'set-cdr-s 'read-modify-write 'symbol)
(definstructionclass 'set-cddr
'(al . set-cddr-al)
'(s . set-cddr-s))
(2byte 'set-cddr-al 'read-modify-write 'al)
(2byte 'set-cddr-s 'read-modify-write 'symbol)
(definstructionclass 'spread
'(al . spread-al))
(2byte 'spread)
(2byte 'spread-al 'read 'al)
(definstructionclass 'replace-car
'(al . replace-car-al))
(1byte 'replace-car)
(1byte 'replace-car-al 'read 'al)
(definstructionclass 'replace-cdr
'(al . replace-cdr-al))
(1byte 'replace-cdr)
(1byte 'replace-cdr-al 'read 'al)
(2byte 'assoc)
(2byte 'assq)
(2byte 'member)
(2byte 'memq)
(definstructionclass 'endp
'(al . endp-al))
(2byte 'endp)
(1byte 'endp-al 'read 'al)
(2byte 'getf)
(2byte 'putf)
;;; Symbol manipulation:
(1byte 'get-value)
(1byte 'set-value)
(1byte 'get-definition)
(2byte 'set-definition)
(2byte 'get-plist)
(2byte 'set-plist)
(2byte 'get-pname)
(2byte 'get-package)
(2byte 'set-package)
(2byte 'boundp)
(2byte 'fboundp)
(2byte 'get)
(2byte 'put)
;;; Array manipulation:
(2byte 'vector-length)
(2byte 'g-vector-length)
(2byte 'simple-string-length)
(2byte 'simple-bit-vector-length)
(2byte 'get-vector-subtype)
(2byte 'set-vector-subtype)
(2byte 'get-vector-access-code)
(2byte 'shrink-vector)
(1byte 'typed-vref)
(1byte 'typed-vset)
(2byte 'header-length)
(2byte 'header-ref)
(2byte 'header-set)
(1byte 'aref1)
(definstructionclass 'svref
'(psic . svref-psic))
(1byte 'svref-psic 'read 'psic)
(1byte 'svref)
(1byte 'schar)
(1byte 'sbit)
(2byte 'aset1)
(1byte 'svset)
(1byte 'scharset)
(1byte 'sbitset)
(2byte 'bit-bash)
(2byte 'byte-blt)
(2byte 'find-character)
(2byte 'find-character-with-attribute)
(2byte 'sxhash-simple-string)
;;; Type predicates:
(2byte 'get-type)
(2byte 'get-space)
(2byte 'bit-vector-p)
(2byte 'simple-bit-vector-p)
(2byte 'simple-integer-vector-p)
(1byte 'stringp)
(1byte 'simple-string-p)
(2byte 'bignump)
(2byte 'long-float-p)
(2byte 'complexp)
(2byte 'ratiop)
(2byte 'integerp)
(2byte 'rationalp)
(2byte 'floatp)
(2byte 'numberp)
(2byte 'general-vector-p)
(1byte 'simple-vector-p)
(2byte 'compiled-function-p)
(2byte 'arrayp)
(2byte 'vectorp)
(1byte 'complex-array-p)
(1byte 'symbolp)
(1byte 'listp)
(1byte 'atom)
(1byte 'consp)
(1byte 'fixnump)
(2byte 'short-float-p)
(2byte 'characterp)
;;; Arithmetic and Logic:
(2byte 'integer-length)
(2byte 'float-short)
(2byte 'realpart)
(2byte 'imagpart)
(2byte 'numerator)
(2byte 'denominator)
(2byte 'decode-float)
(2byte 'scale-float)
(definstructionclass '=
'(al . =-al)
'(psic . ((psic . =-psic)
(0 . =-psic0)
(1 . =-psic1))))
(1byte '=)
(1byte '=-al 'read 'al)
(1byte '=-psic 'read 'psic)
(1byte '=-psic0 'read 'psic 0)
(1byte '=-psic1 'read 'psic 1)
(definstructionclass '<
'(al . <-al)
'(psic . <-psic))
(1byte '<)
(1byte '<-al 'read 'al)
(1byte '<-psic 'read 'psic)
(definstructionclass '>
'(al . >-al)
'(psic . >-psic))
(1byte '>)
(1byte '>-al 'read 'al)
(1byte '>-psic 'read 'psic)
(2byte 'truncate)
(definstructionclass '+
'(al . +-al)
'(psic . ((psic . +-psic)
(1 . +-psic1))))
(1byte '+)
(1byte '+-psic 'read 'psic)
(1byte '+-psic1 'read-modify-write 'psic 1)
(1byte '+-al 'read 'al)
(definstructionclass '-
'(al . --al)
'(psic . ((psic . --psic)
(1 . --psic1))))
(1byte '-)
(1byte '--psic 'read 'psic)
(1byte '--psic1 'read-modify-write 'psic 1)
(1byte '--al 'read 'al)
(2byte '*)
#+Common
(2byte '/ )
#-Common
(2byte '//)
(instrsynonym '+-psic1 '1+)
(1byte 'fixnum-1+-al 'read-modify-write 'al)
(instrsynonym '--psic1 '1-)
(1byte 'fixnum-1--al 'read-modify-write 'al)
(1byte 'negate)
(2byte 'abs)
(2byte 'logand)
(2byte 'logior)
(2byte 'logxor)
(2byte 'lognot)
(2byte 'boole)
(2byte 'ash)
(2byte 'ldb)
(2byte 'mask-field)
(2byte 'dpb)
(2byte 'deposit-field)
(2byte 'lsh)
(2byte 'logldb)
(2byte 'logdpb)
;;; Branching and dispatching:
(1byte 'branch-forward 'short-branch-forward)
(2byte 'long-branch-forward 'long-branch-forward)
(1byte 'branch-backward 'short-branch-backward)
(2byte 'long-branch-backward 'long-branch-backward)
(1byte 'branch-null-forward 'short-branch-forward)
(2byte 'long-branch-null-forward 'long-branch-forward)
(1byte 'branch-not-null-forward 'short-branch-forward)
(2byte 'long-branch-not-null-forward 'long-branch-forward)
(1byte 'branch-null-backward 'short-branch-backward)
(2byte 'long-branch-null-backward 'long-branch-backward)
(1byte 'branch-not-null-backward 'short-branch-backward)
(2byte 'long-branch-not-null-backward 'long-branch-backward)
(1byte 'branch-save-not-null-forward 'short-branch-forward)
(2byte 'long-branch-save-not-null-forward 'long-branch-forward)
(1byte 'branch-save-not-null-backward 'short-branch-backward)
(2byte 'long-branch-save-not-null-backward 'long-branch-backward)
(2byte 'dispatch 'short-dispatch)
(2byte 'long-dispatch 'long-dispatch)
;;; Function call and return:
(definstructionclass 'call
'(al . call-al)
'(c . ((c . call-c)
(1 . call-c1)
(2 . call-c2)
(3 . call-c3)
(4 . call-c4)
(5 . call-c5)
(6 . call-c6)
(7 . call-c7)
(8 . call-c8))))
(2byte 'call)
(1byte 'call-al 'read 'al)
(1byte 'call-c 'read 'constant)
(1byte 'call-c1 'read 'constant 1)
(1byte 'call-c2 'read 'constant 2)
(1byte 'call-c3 'read 'constant 3)
(1byte 'call-c4 'read 'constant 4)
(1byte 'call-c5 'read 'constant 5)
(1byte 'call-c6 'read 'constant 6)
(1byte 'call-c7 'read 'constant 7)
(1byte 'call-c8 'read 'constant 8)
(definstructionclass 'call-0
'(c . call-0-c))
(2byte 'call-0)
(1byte 'call-0-c 'read 'constant)
(definstructionclass 'call-multiple
'(c . ((c . call-multiple-c)
(1 . call-multiple-c1)
(2 . call-multiple-c2)
(3 . call-multiple-c3)
(4 . call-multiple-c4))))
(2byte 'call-multiple)
(1byte 'call-multiple-c 'read 'constant)
(1byte 'call-multiple-c1 'read 'constant 1)
(1byte 'call-multiple-c2 'read 'constant 2)
(1byte 'call-multiple-c3 'read 'constant 3)
(1byte 'call-multiple-c4 'read 'constant 4)
(1byte 'start-call)
(definstructionclass 'push-last
'(al . ((al . push-last-al)
(0 . push-last-al0)
(1 . push-last-al1)
(2 . push-last-al2)
(3 . push-last-al3)))
'(c . push-last-c)
'(s . push-last-s))
(instrsynonym 'start-call 'push-last)
(1byte 'push-last-al 'read 'al)
(1byte 'push-last-al0 'read 'al 0)
(1byte 'push-last-al1 'read 'al 1)
(1byte 'push-last-al2 'read 'al 2)
(1byte 'push-last-al3 'read 'al 3)
(1byte 'push-last-c 'read 'constant)
(1byte 'push-last-s 'read 'symbol)
(definstructionclass 'return
'(al . return-al)
'(c . return-c))
(1byte 'return)
(1byte 'return-al 'read 'al)
(1byte 'return-c 'read 'constant)
(2byte 'escape-return)
(2byte 'break-return)
(2byte 'catch)
(2byte 'catch-multiple)
(2byte 'catch-all)
(2byte 'throw)
;;; Miscellaneous:
(definstructionclass 'eq
'(al . eq-al)
'(c . ((c . eq-c)
(1 . eq-c1)
(2 . eq-c2)
(3 . eq-c3))))
(1byte 'eq)
(1byte 'eq-al 'read 'al)
(1byte 'eq-c 'read 'constant)
(1byte 'eq-c1 'read 'constant 1)
(1byte 'eq-c2 'read 'constant 2)
(1byte 'eq-c3 'read 'constant 3)
(2byte 'eql)
(definstructionclass 'set-null
'(al . set-null-al))
(1byte 'set-null-al 'write 'al)
(1byte 'set-null 'write)
(1byte 'set-t)
(instrsynonym 'push-psic0 'set-0 'write)
(1byte 'make-predicate)
(1byte 'not-predicate)
(1byte 'values-to-n)
(1byte 'n-to-values)
(1byte 'force-values)
(2byte 'flush-values)
;;; System hacking:
(1byte 'make-immediate-type)
(2byte '8bit-system-ref)
(2byte '8bit-system-set)
(2byte '16bit-system-ref)
(2byte '16bit-system-set)
(2byte 'collect-garbage)
(2byte 'newspace-bit)
(2byte 'kernel-trap)
(2byte 'halt)
(2byte 'arg-in-frame)
(2byte 'active-call-frame)
(2byte 'set-call-frame)
(2byte 'current-open-frame)
(2byte 'set-open-frame)
(2byte 'current-stack-pointer)
(2byte 'current-binding-pointer)
(2byte 'read-control-stack)
(2byte 'write-control-stack)
(2byte 'read-binding-stack)
(2byte 'write-binding-stack)
;;; %%% Things at the end just for now: %%%
(2byte 'long-float-ref)
(2byte 'long-float-set)
(2byte 'active-catch-frame)
(2byte 'set-catch-frame)
(2byte 'io-get-time)
(2byte 'sap-system-ref)
(2byte 'pointer-system-set)
(2byte 'signed-16bit-system-ref)
(2byte 'signed-32bit-system-ref)
(2byte 'signed-32bit-system-set)
(2byte 'check-<=)
(2byte 'sxhash-simple-substring)
(2byte 'profile-return)
(setq *1byte-instruction-counter* #.*1byte-instruction-counter*)
(setq *2byte-instruction-counter* #.*2byte-instruction-counter*)
;(format t "[~3D 1-byte instructions have been defined.]"
; (1- #.*1byte-instruction-counter*))
;(terpri)
;(format t "[~3D 2-byte instructions have been defined.]"
; #.*2byte-instruction-counter*)