(;; SCCS : @(#)INSTRS.LSP 3.8 1/29/86
;;; File : xerox.d/instrs.lsp
;;; Author : Richard A. O'Keefe
;;; Purpose: Describe all the instructions currently implemented
PROGN
;; Each instruction is described by a line
;; (instruction arguments) ; mode file line
;; which describes the SOURCE form of the instruction in a .DNG file
;; and says whereabouts in the emulator it is defined. The line
;; numbers are getting out of date, I shall have to maintain them by
;; hand. The meaning of the argument descriptions is
;
; byte -- an 8-bit literal value
; size -- a 16-bit literal for instruction word <<3>>
; word -- a 16-bit literal for instruction word 2
; atom -- a 16-bit atom address, source has the symbol
; cell -- a 32-bit tagged cell, source has a constant
; a1 -- an 8-bit A register number for instr word 1
; a2 -- an 8-bit A register number for instr word 2
; y1 -- an 8-bit Y variable number for instr word 1
; y2 -- an 8-bit Y variable number for instr word 2
; clause -- a 24-bit clause pointer (no source form)
; procedure -- a 24-bit procedure pointer (atom arity module)
; offset -- a 24-bit instruction pointer (+offset)
; alias -- an alternative name for another instruction
; extend -- this is a 2-byte instruction, there are no
; -- args, or one word, or one cell.
; No argument information means that the instruction has no arguments, but
; is so common that it should not be an "extend"ed form.
;; QP.opcode is an array of function names.
;; Instructions are numbered 2, 4, 6, ..., 252.
;; Instruction 0 is a fault, and instruction 254 is for debugging.
;; QP.opcode[I+0] is the read-mode handler for instruction I.
;; QP.opcode[I+1] is the write-mode handler for instruction I.
;; QP.extendR and QP.extendW are blocks of 16-bit atom numbers,
;; for use in R.extend and W.extend respectively.
(def.global QP.opcode)
(def.global QP.extendR)
(def.global QP.extendW)
(def.global QP.INSTRUCTION.HARRAY)
(def.global QP.EXTENSION.HARRAY)
(def.global QP.PERMANENT.OFFSET)
(def.global QP.EXTENSION.OPCODE)
;; (QP.OP.CODE name)
;; is given the symbolic name of a Prolog instruction as an atom, and
;; returns the (read-mode) number of that instruction.
(def.subr QP.OP.CODE (INSTRUCTION)
(if (GETHASH INSTRUCTION QP.EXTENSION.HARRAY)
then (IPLUS (GETHASH INSTRUCTION QP.EXTENSION.HARRAY) 512)
else (GETHASH INSTRUCTION QP.INSTRUCTION.HARRAY)
)
)
;; (QP.DESCRIBE.INSTRUCTIONS list-of-descriptions)
;; is called with one argument: a complete list of the Quintus Prolog
;; instructions and their argument types. (The comment saying which
;; modes an instruction exists in should perhaps move into the data.)
;; It initialises QP.INSTRUCTION.HARRAY with the information, and
;; assigns specific opcodes to the instructions. It also maintains
;; QP.opcode, which used to be done by loading, but that ran into the
;; usual difficulties with the file package. As a consequence of the
;; new way of initialising QP.opcode, it will have some W.xxx entries
;; which do not correspond to real functions, but that does no harm.
(def.subr QP.DESCRIBE.INSTRUCTIONS (ARGS)
(PROG (COUNTER SECONDARY LAST INSTR FIRST)
;; Create the three tables
(SETQ QP.opcode (ARRAY 384 'POINTER 'SHOULDNT 0))
(SETQ QP.extendR (\ALLOCBLOCK 128))
(SETQ QP.extendW (\ADDBASE QP.extendR 1))
(SETQ QP.INSTRUCTION.HARRAY (HARRAY 500))
(SETQ QP.EXTENSION.HARRAY (HARRAY 200))
(SETQ QP.PERMANENT.OFFSET 2)
(SETQ QP.EXTENSION.OPCODE 2)
(SETQ COUNTER 0)
(SETQ SECONDARY 0)
(for ENTRY in ARGS do
(SETQ INSTR (CAR ENTRY)) ;; the opcode
(SETQ FIRST (CADR ENTRY)) ;; what kind of arg 1?
(if (EQ FIRST 'extend) then
;; extended (slow) opcode
(SETQ SECONDARY (IPLUS SECONDARY 2))
(PUTHASH INSTR QP.EXTENSION.OPCODE QP.INSTRUCTION.HARRAY)
(PUTHASH SECONDARY ENTRY QP.EXTENSION.HARRAY)
(PUTHASH INSTR SECONDARY QP.EXTENSION.HARRAY)
(\PUTBASE QP.extendR SECONDARY (\LOLOC
(SETA QP.opcode (IPLUS SECONDARY 256) (PACK* 'R. INSTR)) ))
(\PUTBASE QP.extendW SECONDARY (\LOLOC
(SETA QP.opcode (IPLUS SECONDARY 257) (PACK* 'W. INSTR)) ))
elseif (EQ FIRST '*) then
;; memory version of Areg instruction
(SETQ COUNTER (IPLUS COUNTER 2))
(PUTHASH COUNTER (APPEND ENTRY (LIST LAST)) QP.INSTRUCTION.HARRAY)
(PUTHASH INSTR COUNTER QP.INSTRUCTION.HARRAY)
(SETA QP.opcode COUNTER (PACK* 'R. INSTR))
(SETA QP.opcode (ADD1 COUNTER) (PACK* 'W. INSTR))
else
;; ordinary instruction
(SETQ COUNTER (IPLUS COUNTER 2))
(SETQ LAST INSTR) ;; for (x *) instructions
(PUTHASH INSTR COUNTER QP.INSTRUCTION.HARRAY)
(PUTHASH COUNTER
(LET ((SECOND (CADDR ENTRY)))
(if (NULL FIRST) then
ENTRY
elseif (NULL SECOND) then
(LIST INSTR FIRST (CDR ENTRY))
else
(LIST INSTR (PACK* FIRST '%. SECOND) (CDR ENTRY))
)) QP.INSTRUCTION.HARRAY)
(SETA QP.opcode COUNTER (PACK* 'R. INSTR))
(SETA QP.opcode (ADD1 COUNTER) (PACK* 'W. INSTR))
)
)
)
)
(def.subr QP.init.instrs ()
(QP.DESCRIBE.INSTRUCTIONS '(
; INSTRUCTION ARGS MODE FILE LINE
; ------------- ---- ---- ---------- ----
(extend byte); both interpret.lsp
(add extend ); both arith.lsp
(add.neg.word extend word); both arith.lsp
(add.pos.word extend word); both arith.lsp
(allocate ); both call.lsp 18
(apply extend ); both call.lsp 49
(body.cut ); both cut.lsp 74
(boolean.and extend ); both arith.lsp
(boolean.not extend ); both arith.lsp
(boolean.or extend ); both arith.lsp
(boolean.xor extend ); both arith.lsp
(call size procedure);both call.lsp 148
(call.lisp byte ); read lisp.lsp
(compare extend ); both meta.lsp 301
(cut.proceed ); both cut.lsp 84
(deallocate ); both call.lsp 81
(depart procedure); both call.lsp 137
(depart.cut ); both cut.lsp 95
(divide extend ); both arith.lsp
(either size offset); both index.lsp 89
(equal.to extend ); both arith.lsp
(equal.to.else offset ); both arith.lsp
(execute procedure); both call.lsp 128
(fail ); both fail.lsp 59
(fix extend ); both arith.lsp
(float extend ); both arith.lsp
(get.Ai.boxed a1 cell ); both getread.lsp 448
(get.AiM.boxed * ); both getread.lsp 448
(get.Ai.constant a1 cell ); both getread.lsp 405
(get.AiM.constant * ); both getread.lsp 405
(get.Ai.float a1 cell ); both getread.lsp 494
(get.AiM.float * ); both getread.lsp 494
(get.Ai.list a1 ); both getread.lsp 621
(get.AiM.list * ); both getread.lsp 621
(get.Ai.nil a1 ); both getread.lsp 579
(get.AiM.nil * ); both getread.lsp 579
(get.Ai.structure a1 functor); both getread.lsp 657
(get.AiM.structure * ); both getread.lsp 657
(get.Ai.symbol a1 atom ); both getread.lsp 544
(get.AiM.symbol * ); both getread.lsp 544
(get.Ai.value.Xn a1 a2 ); both getread.lsp 313
(get.AiM.value.Xn * ); both getread.lsp 313
(get.Ai.value.XnM * ); both getread.lsp 313
(get.AiM.value.XnM * ); both getread.lsp 313
(get.Ai.value.Yn a1 y2 ); both getread.lsp 347
(get.AiM.value.Yn * ); both getread.lsp 347
; (get.Ai.variable.Xn alias put.Ai.value.Xn)
(get.Ai.variable.Yn a1 y2 ); both getread.lsp 291
(get.AiM.variable.Yn * ); both getread.lsp 291
(greater.than extend ); both arith.lsp
(greater.than.else offset ); both arith.lsp
(head.cut ); both cut.lsp 64
(initialize.Yn y1 ); both putwrite.lsp 24
(integer.divide extend ); both arith.lsp
(is.a byte ); both meta.lsp 20
(jump.to offset ); both index.lsp 110
(just.me.else clause ); read index.lsp 64
(left.shift extend ); both arith.lsp
(less.than extend ); both arith.lsp
(less.than.else offset ); both arith.lsp
(load.constant extend cell); both arith.lsp 303
(load.neg.word extend word); both arith.lsp 321
(load.pos.word extend word); both arith.lsp 315
(load.value.Xn a1 ); both arith.lsp 251
(load.value.XnM * ); both arith.lsp 251
(load.value.Yn y1 ); both arith.lsp 271
(minus extend ); both arith.lsp 90
(modulus extend ); both arith.lsp
(multiply extend ); both arith.lsp
(not.equal.to extend ); both arith.lsp
(not.equal.to.else offset ); both arith.lsp
(not.less.than extend ); both arith.lsp
(not.less.than.else offset ); both arith.lsp
(not.greater.than extend ); both arith.lsp
(not.greater.than.else offset ); both arith.lsp
(or offset ); read index.lsp 132
(or.finally ); read index.lsp 138
(proceed ); both call.lsp 133
(progress ); both call.lsp 141
(put.Ai.constant a1 cell ); both putwrite.lsp 188
(put.AiM.constant * ); both putwrite.lsp 188
(put.Ai.list a1 ); both putwrite.lsp 255
(put.AiM.list * ); both putwrite.lsp 255
(put.Ai.nil a1 ); both putwrite.lsp 207
(put.AiM.nil * ); both putwrite.lsp 207
(put.Ai.structure a1 functor); both putwrite.lsp 275
(put.AiM.structure * ); both putwrite.lsp 275
(put.Ai.symbol a1 atom ); both putwrite.lsp 228
(put.AiM.symbol * ); both putwrite.lsp 228
(put.Ai.unsafe.Yn a2 y1 ); both putwrite.lsp 162
(put.AiM.unsafe.Yn * ); both putwrite.lsp 162
(put.Ai.value.Xn a2 a1 ); both putwrite.lsp 135
(put.Ai.value.XnM * ); both putwrite.lsp 135
(put.AiM.value.Xn * ); both putwrite.lsp 135
(put.AiM.value.XnM * ); both putwrite.lsp 135
(put.Ai.value.Yn a2 y1 ); both putwrite.lsp 81
(put.AiM.value.Yn * ); both putwrite.lsp 81
(put.Ai.variable.Yn a2 y1 ); both putwrite.lsp 45
(put.AiM.variable.Yn * ); both putwrite.lsp 45
(put.Ai.void a1 ); both putwrite.lsp 10
(put.AiM.void * ); both putwrite.lsp 10
(raw.float extend ); both arith.lsp 59
(interpret.me ); both skel.lsp
(retry.me.else clause ); read index.lsp 71
(right.shift extend ); both arith.lsp
(send.variable.Ai a1 ); read lisp.lsp 135
(send.variable.AiM * ); read lisp.lsp 135
(start.calling functor ); read lisp.lsp 127
(store.float extend cell); both arith.lsp 231
(store.integer extend cell); both arith.lsp 222
(store.value.Xn a1 ); both arith.lsp 199
(store.value.XnM * ); both arith.lsp 199
(store.value.Yn y1 ); both arith.lsp 205
(store.variable.Xn a1 ); both arith.lsp 174
(store.variable.XnM * ); both arith.lsp 174
(store.variable.Yn y1 ); both arith.lsp 183
(subtract extend ); both arith.lsp
(trust.me.else clause ); read index.lsp 81
(try.me.else clause ); read index.lsp 30
(unify.boxed cell ); read getread.lsp 468
; write putwrite.lsp 196
(unify.constant cell ); read getread.lsp 421
; write putwrite.lsp 196
(unify.float cell ); read getread.lsp 514
; write putwrite.lsp 196
(unify.list ); read getread.lsp 638
; write putwrite.lsp 263
(unify.local.Xn a1 ); read getread.lsp 334
; write putwrite.lsp 153
(unify.local.XnM * ); read getread.lsp 334
; write putwrite.lsp 153
(unify.local.Yn y1 ); read getread.lsp 369
; write putwrite.lsp 126
(unify.nil ); read getread.lsp 594
; write putwrite.lsp 214
(unify.structure functor ); read getread.lsp 681
; write putwrite.lsp 285
(unify.symbol atom ); read getread.lsp 561
; write putwrite.lsp 237
(unify.value.Xn a1 ); read getread.lsp 323
; write putwrite.lsp 145
(unify.value.XnM * ); read getread.lsp 323
; write putwrite.lsp 145
(unify.value.Yn y1 ); read getread.lsp 357
; write putwrite.lsp 91
(unify.variable.Xn a1 ); read getread.lsp 279
; write putwrite.lsp 69
(unify.variable.XnM * ); read getread.lsp 279
; write putwrite.lsp 69
(unify.variable.Yn y1 ); read getread.lsp 301
; write putwrite.lsp 56
(unify.void byte ); read getread.lsp 267
; write putwrite.lsp 19
(send.direct.Ai a1 ); read lisp.lsp 135
(send.direct.AiM * ); read lisp.lsp 135
(trap procedure); read skel.lsp
(just.index.else clause ); read index.lsp
(try.index.else clause ); read index.lsp
(retry.index.else clause ); read index.lsp
(trust.index.else clause ); read index.lsp
(ignore.me ); both skel.lsp
(ignore.me.but.keep.me ); both skel.lsp
(retry.at ); both skel.lsp
(fail.on.retry ); both skel.lsp
(store.skeleton extend ); both skel.lsp
(load.choice.point ); both cut.lsp 29
(cut.to.choice.point ); both cut.lsp 43
(load.cur.clause ); both skel.lsp
(arg ); both meta.lsp 53
(functor ); both meta.lsp 247
(get.word extend ); both donor.lsp
(put.word extend ); both donor.lsp
(get.addr extend ); both donor.lsp
(put.addr extend ); both donor.lsp
(gettopval atom ); both donor.lsp
(settopval atom ); both donor.lsp
))
)
(def.init (QP.init.instrs))
;; The following function prints a table of instruction numbers
;; so that parts of the Prolog system which need these numbers
;; can be updated.
(def.subr QP.list.instrs (FLAG)
(SETQ FLAG (NOT (FBOUNDP 'R.call))) ; has other code been loaded?
(PRINTOUT T "Normal Instructions" T T)
(for I from 0 to 255 when (AND (NEQ (ELT QP.opcode I) 'SHOULDNT)
(OR FLAG (FBOUNDP (ELT QP.opcode I)) )) do
(PRINTOUT T .I3 I " = " (ELT QP.opcode I)
" (" (TIMES I 256) ")" T)
)
(PRINTOUT T T "Extended Instructions" T T)
(for I from 256 to 284 when (AND (NEQ (ELT QP.opcode I) 'SHOULDNT)
(OR FLAG (FBOUNDP (ELT QP.opcode I)) )) do
(PRINTOUT T .I3 (DIFFERENCE I 256) " = " (ELT QP.opcode I)
" (" (PLUS I 256) ")" T)
)
(PRINTOUT T T)
)
) STOP