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