(;; SCCS   : @(#)SKEL.LSP	3.12 2/3/86
;;; File   : $xerox/skel.lsp
;;; Author : Richard A. O'Keefe
;;; Purpose: Basic interpreter support
PROGN
;;; ------------------------------------------------------------------------
;;
;;	WARNING: This material is CONFIDENTIAL and proprietary to Quintus
;;	Computer Systems Inc.  This notice is protection against inadvertent
;;	disclosure and does not constitute publication or reflect any intent
;;	to publish.
;;
;;	Copyright (C) 1985, by Quintus Computer Systems, Inc.
;;	All rights reserved.
;;
;;	CAVEAT LECTOR: This software is under development.  No warrantee is
;;	made that it is any use for anything at all.
;;
;;; ------------------------------------------------------------------------


;;;  This instruction is
;;;
;;;	+--------+--------------------------+
;;;	|  Trap  |    address of proc/2     |
;;;	+--------+--------------------------+
;;;
;;;  when it is executed, the C register (in the Sun/Vax emulators, PR)
;;;  points to a procdeure record, which has the format
;;;
;;;	+-----------------------------------+
;;;C+ 0	| link to next predicate in chain   |
;;;	+--------+--------+-----------------+
;;;C+ 2	|FuncTag | Arity  |  symbol number  |
;;;	+--------+--------+-----------------+
;;;C+ 4	|AtomTag |    0   |  module number  |
;;;	+--------+--------+-----------------+	
;;;C+ 6	|  arity again as an unboxed FIXP   |
;;;	+--------+--------------------------+
;;;C+ 8	|        |  pointer to first clause |
;;;	+--------+--------------------------+
;;;C+10	|        |  pointer to last clause  |
;;;	+--------+--------+-----------------+
;;;C+12	|  flag word one  |  flag word two  |
;;;	+-----------------+-----------------+
;;;
;;;  the symbol number is the InterLisp atom number of the name of the
;;;  predicate; C+2 is a tagged functor cell.  The module number is the
;;;  InterLisp atom number of the name of the module this predicate is
;;;  defined in; C+4 is a tagged atom cell.  Some of these fields are
;;;  not used in the Prolog-1108 implementation; the layout is identical
;;;  to the layout used on the Sun and Vax so that the amount of system-
;;;  dependent code is minimised.  If we need a scaled version of the
;;;  arity, say arity*2, C+6 is a good place to put it, and then we can
;;;  use word access (C+7) rather than byte access (C+5bytes) to get at
;;;  it.
;;;  
;;;  The point of the trap instruction is to convert a call on
;;;	foo(X1,...,Xn)		arity=n, symbol=foo, module=whatever
;;;  into a call on
;;;	proc(foo(X1,...,Xn), C')
;;;  where C' is a coded form of the address of the procedure record.
;;;  It is not sufficient to pass just the term foo(X1,...,Xn), as there
;;;  could be any number of procedures with that name, all in different
;;;  modules.  On the Sun and Vax, C' is the address represented as an
;;;  integer.  That works well because only 29-bit integers are needed.
;;;  It will not work well on the Dandelion, as large integers have to
;;;  be boxed.  We'll see later that addresses of this form have to be
;;;  passed around a lot in the interpreter, so we'll want another way
;;;  of hacking them.  So we shall represent C' as the adress itself
;;;  with a slightly different "immed" tag, one which is clearly an
;;;  immediate constant but is not a number.

(def.macro QP.functor (C)
    (if (NEQ C 'C) then (SHOULDNT QP.functor))
   `(get.cell ,C 1)
)

(def.both.mode trap (address)
    (put.16 I (PROC.ARITY (get.24 C)))
    (if (zero I) then
	(put.Aval 1 (QP.functor C))
    else
	;;  dump the A registers into memory
	(put.Amem 1 (get.Aval 1))
	(put.Amem 2 (get.Aval 2))
	(put.Amem 3 (get.Aval 3))
	(put.Amem 4 (get.Aval 4))
	(put.Aval 1 (tag.struct H))
	(put.cell H 0 (QP.functor C))
	(increment.cell.pointer H)
	(put.24 S (loc.Amem 1))
	(until (zero I)
	    (put.32 T0 (get.cell S 0))
	    (increment.cell.pointer S)
	    (select.4 T0
		(ref.tag.8
		    (put.24 R  (untag.ref T0))
		    (put.32 T0 (get.cell R 0))
		    (reselect.when.bound T0 R)
		    (if (before H R) then	; variable is local
			(put.32 T0 (tag.ref H))
			(bind.local R T0)
		    ))
		(PROGN)
	    )
	    (put.cell H 0 (get.32 T0))
	    (increment.cell.pointer H)
	    (decrement.counter I)
	)
    )
    (put.Aval 2 (tag.other (get.24 C)))
    (put.24 C (address.operand))
    (do.execute)
)



(def.read.mode ignore.me (extend)
    ;;  "call" port, execute backtrack instruction in write mode
    (continue.writing 0)
)
(def.write.mode ignore.me (extend)
    ;;  "redo" port, execute backtrack instruction in read mode
    (continue.reading 0)
)


(def.read.mode ignore.me.but.keep.me (extend)
    ;;  "call" port, execute backtrack instruction in write mode
    (continue.writing 0)
)
(def.write.mode ignore.me.but.keep.me (extend)
    ;;  "redo" port, execute backtrack instruction in read mode
    (continue.reading 0)
)


(def.read.mode retry.at (extend address)
    ;;  "redo" port; we've been backtracked into
    (continue.writing.at (next.address.operand))
)
(def.write.mode retry.at (extend address)
    ;;  "call" port; we've been "ignored" into
    (continue.reading.at (next.address.operand))
)

(def.read.mode fail.on.retry (extend)
    ;;  "fail" port; we've been backtracked into
    (put.24 B  (get.addr B saved.B))
    (put.24 HB (get.addr B saved.H))	; uses *new* B
    (fast.fail)
)
(def.write.mode fail.on.retry (extend)
    ;;  "fail" port; we've been skipped into (NO clauses)
    (fast.fail)
)


;;  This file is obliged to explicitly take into account the fact that
;;  cells are pairs of half-words.  I get up to a very sneaky trick:
;;  the most significant half-word is effectively all tag (except for
;;  constants), and the right half-word is a half-word offset.  These
;;  macros do addressy things for half-words.  The conditions on them
;;  are not necessary for them to be well behaved; they are there to
;;  ensure that I haven't used them anywhere I didn't mean to.

(def.macro get.half (Base Offset)
    (if (OR (NEQ Base 'S) (NOT (SMALLP Offset))) then
	(SHOULDNT 'get.half))
   `(\GETBASE (get.24 ,Base) ,Offset)
)

(def.macro put.half (Base Offset Val)
    (if (NOT (AND (MEMB Base '(H S C)) (SMALLP Offset))) then
	(SHOULDNT 'put.half))
   `(\PUTBASE (get.24 ,Base) ,Offset ,Val)
)

(def.macro add.half (Base Offset)
    (if (OR (NEQ Base 'C) (NEQ Offset 'N)) then
	(SHOULDNT 'add.half))
   `(\ADDBASE (get.24 ,Base) (get.16 ,Offset))
)


(def.read.mode interpret.me (extend)
    (set.top.of.stack)		; sets R
    (put.cell R 0 (get.Aval 1))	; save A1 (save registers)
    (put.addr R 1 (get.24 B0))	; \
    (put.addr R 2 (get.24 E ))	;  \
    (put.addr R 3 (get.24 CP))	;   \
    (put.addr R 4 (get.24 B ))	;	(create.choice.point)
    (put.addr R 5 (get.24 P ))	;  <--- except this is different
    (put.addr R 6 (get.24 TR))	;
    (put.addr R 7 (get.24 H ))	;
    (put.24 B  (add.cell R 8))	;   /
    (put.24 HB (get.24 H))	;  /
    (check.stack B)		; /
    (interpret.me)
)
(def.write.mode interpret.me (extend)
    (put.Aval 1 (get.cell B -8)); (restore.registers)
    (put.24 HB (get.24 H))
    (put.addr B saved.BP (get.24 P))
    (interpret.me)
)

;;  (interpret.me)
;;  is the common part of the read and write modes of the
;;  (interpret.me) instruction.  P points to the backtrack instruction
;;  of an interpreted clause (so the clause's address is P-1).  We are
;;  to copy this term to the heap, and unify it with A1.

(def.open interpret.me ()
    (put.16 I (IDIFFERENCE (get.code P 6) 4))	; number of cells to copy
    (check.heap)			; ensure room for term
    (put.Aval 2 (tag.struct H))		; always a compound term
    (put.24 S (add.code P 7))		; S->first cell of term
    (until (zero I)
	(put.16 N (get.half S 0))	; the super-tag
	(if (ILESSP (get.16 N) symbol.tag.16) then	; pointer
	    (\PUTBASEPTR  (get.24 H) 0	; bottom 24 bits
		(\ADDBASE (get.24 HB) (get.half S 1)))
	    (\PUTBASEBYTE (get.24 H) 0	; top 8 bits
		(LRSH (get.16 N) 8))
	else
	    (put.half H 0 (get.16 N))
	    (put.half H 1 (get.half S 1))
	)
	(increment.cell.pointer H)
	(increment.cell.pointer S)
	(decrement.counter I)
    )
    (put.24 CurClause (add.code P -1))		; save clause address
    (put.32 T0 (get.Aval 1))
    (put.32 T1 (get.Aval 2))
    (unify.and.continue 3)			; **HACK**
)



;;  (len.term)
;;  calculates the size of the term represented by A1, and returns
;;  that size in register N.  If the size would exceed 32767 cells,
;;  including the list cell header, it aborts.
;;  	N	is 32767 - the size of the CLAUSE in cells
;;  	H	is the stack top (as in unify.one, compare)
;;  	S	is the stack base (as in unify.one, compare)
;;  	T0, R	are the current term, as usual

(def.open len.term () (PROG ()
    (put.16 N 32763)			; 2↑15-4 (4=size of header)
    (check.heap)			; check that H stack can't overflow
    (put.24 S (get.24 H))
    (put.word H 2 0)
    (put.32 T0 (get.Aval 1))		; term to find size of
L   (select.4 T0
	(ref.tag.8
	    (put.24 R  (untag.ref T0))
	    (put.32 T0 (get.cell R 0))
	    (reselect.when.bound T0 R)
	    NIL)
	(struct.tag.8
	    (put.24 R  (untag.struct T0))
	    (put.32 T0 (get.cell R 0))
	    (put.16 I  (arity.of T0))
	    (if (ILEQ (get.16 N) (get.16 I)) then
		(put.24 H (get.24 S))
		(QP.OVERFLOW 20))
	    (put.16 N (IDIFFERENCE (IDIFFERENCE (get.16 N) (get.16 I)) 1))
	    (put.16 I (SUB1 (get.16 I)))
	    (if (NOT (zero I)) then
		(increment.cell.pointer H 3)
		(put.addr H 0 (add.cell R 2))
		(put.word H 2 (get.16 I))
	    )
	    (put.32 T0 (get.cell R 1))
	    (reselect))
	(list.tag.8
	    (put.24 R  (untag.list T0))
	    (if (ILEQ (get.16 N) 1) then
		(put.24 H (get.24 S))
		(QP.OVERFLOW 20))
	    (put.16 N (IDIFFERENCE (get.16 N) 2))
	    (increment.cell.pointer H 3)
	    (put.addr H 0 (add.cell R 1))
	    (put.word H 2 1)
	    (put.32 T0 (get.cell R 0))
	    (reselect))
	(PROGN)
    )
    (put.16 I (get.word H 2))
    (if (zero I) then
	(put.16 N (IDIFFERENCE 32767 (get.16 N)))
	(RETURN))
    (put.24 R (get.addr H 0))
    (decrement.counter I)
    (if (zero I) then
	(decrement.cell.pointer H 3)	; pop completed frame
    else
	(put.addr H 0 (add.cell R 1))
	(put.word H 2 (get.16 I))
    )
    (put.32 T0 (get.cell R 0))
    (GO L)
))


;;  (put.term)
;;  is called with the term to be stored in A1, the size of the term
;;  in N, and the address of a block to store it in in C.  It manages
;;  a stack of (next thing to copy, next place to put a copy, count of
;;  arguments still to be copied) triples like unify.one and compare.
;;  S points to the cell that the current term is to be copied into,
;;  while N counts the number of cells which have been filled in.
;;  This code is only correct when the term to be stored is always a
;;  "struct".  Since the present Prolog system only stores :-(H,B)
;;  and $record(T) terms, we are safe for now.  A tagged pointer to
;;  the first data cell of the clause will be left in the "next clause"
;;  field, but that is about to be smashed anyway, so who cares?

(def.subr QP.HI.CODE (N)
    (SETQ N (QP.OP.CODE N))		; given 0<N<255
    (if (LESSP N 256) then (LLSH N 8)	; return N*256
    else N				; extended opcodeds
    )					; are returned as is
)

(def.open put.term () (PROG ()
    (put.half C 0 (CONSTANT (QP.HI.CODE 'interpret.me)))
    (put.half C 1 (CONSTANT (QP.HI.CODE 'fail.on.retry)))
    (put.half C 6 0)			; high size is 0, NOT TAGGED!
    (put.half C 7 (get.16 N))		; size of CLAUSE in cells
    (put.24 S (add.cell C 1))		; can safely be clobbered
    (put.24 C (add.cell C 4))		; where the functor cell is to go
    (put.16 N 0)			; (halfword) offset for arguments
    (put.32 T0 (get.Aval 1))		; the term to be stored
L   (select.4 T0
	(ref.tag.8
	    (if (EQ (\GET.HI.16 T0) ref.tag.16) then
		;;  this variable has already been bound to an offset
		(put.cell S 0 (get.32 T0))
	    else
		(put.24 R  (untag.ref T0))
		(put.32 T0 (get.cell R 0))
		(if (is.unbound T0 R) then
		    ;;  this variable is not yet bound
		    ;;  The arithmetic expression *does* yield 0..2↑16-1!
		    (put.24 B0 (\VAG2 0 (IPLUS (LLSH
			(IDIFFERENCE (\GET.HI.16 S) (\GET.HI.16 C)) 16)
			(IDIFFERENCE (\GET.LO.16 S) (\GET.LO.16 C)) )) )
		    (put.32 T0 (tag.ref B0))
		    (put.cell S 0 (get.32 T0))
		    (bind.trail R T0)
		else
		    (reselect)
	    )))
	(struct.tag.8
	    (put.24 R  (untag.struct T0))
	    (put.32 T0 (get.cell R 0))
	    (put.16 I  (SUB1 (arity.of T0)))
	    (put.half S 0 struct.tag.16)
	    (put.half S 1 (get.16 N))
	    (put.24 S (add.half C N))
	    (put.cell S 0 (get.32 T0))
	    (if (NOT (zero I)) then
		(increment.cell.pointer H 3)
		(put.addr H 0 (add.cell R 2))
		(put.addr H 1 (add.cell S 2))
		(put.word H 2 (get.16 I))
	    )
	    (put.32 T0 (get.cell R 1))
	    (increment.cell.pointer S)
	    (put.16 N (IPLUS (get.16 N) (Twice (get.16 I) 4) ))
	    (reselect))
	(list.tag.8
	    (put.half S 0 list.tag.16)
	    (put.half S 1 (get.16 N))
	    (put.24 S (add.half C N))
	    (put.16 N (IPLUS (get.16 N) 4))
	    (put.24 R  (untag.list T0))
	    (put.32 T0 (get.cell R 0))
	    (increment.cell.pointer H 3)
	    (put.addr H 0 (add.cell R 1))
	    (put.addr H 1 (add.cell S 1))
	    (put.word H 2 1)
	    (reselect))
	(PROGN
	    (if (IGEQ (super.tag.of T0) other.tag.16) then
		(\ADDREF (untag.immed T0)))
	    (put.cell S 0 (get.32 T0)))
    )
    (put.16 I (get.word H 2))
    (if (zero I) then (RETURN))
    (put.24 R (get.addr H 0))
    (put.24 S (get.addr H 1))
    (decrement.counter I)
    (if (zero I) then
	(decrement.cell.pointer H 3)	; pop completed frame
    else
	(put.addr H 0 (add.cell R 1))
	(put.addr H 1 (add.cell S 1))
	(put.word H 2 (get.16 I))
    )
    (put.32 T0 (get.cell R 0))
    (GO L)
))


(def.read.mode store.skeleton (extend)
    (put.24 CurClause 0)		; in case len.term fails
    (len.term)				; puts length in N
    (LET ((CurClause (\ALLOCBLOCK (get.16 N)) ))
	(\ADDREF CurClause)		; nail it down!
	(put.24 C CurClause)
	(put.term)
	(put.24 CurClause CurClause)
    )
    (fast.fail)
)


(def.both.mode load.cur.clause (extend)
    (put.32 T1 (get.32 T0))
    (put.32 T0 (tag.stack CurClause))
    (continue 0)
)



;;  This is a temporary tool for debugging, to make sure that clauses
;;  are being stored correctly.

(def.subr QP.CLAUSE (CLAUSE)
    (PROG (N I B TAG)
L	(SETQ N (\GETBASE CLAUSE 0))
	(SETQ I (if (EQ (LRSH N 8) 2) then
		     (ELT QP.opcode (IPLUS 256 (LOGAND N 255)))
		else (ELT QP.opcode (LRSH N 8)) ))
	(SETQ N (\GETBASE CLAUSE 1))
	(SETQ B (if (EQ (LRSH N 8) 2) then
		     (ELT QP.opcode (IPLUS 256 (LOGAND N 255)))
		else (ELT QP.opcode (LRSH N 8)) ))
	(SETQ N (\GETBASE CLAUSE 7))
	(PRINTOUT T
	    "Clause @ " CLAUSE
	    " [" I "; " B " " (\GETBASEPTR CLAUSE 2)
	    "; prev " (\GETBASEPTR CLAUSE 4)
	    "; size " N
	    "]" T)
	(while (IGREATERP N 4)
	    (SETQ N (SUB1 N))
	    (SETQ TAG (\GETBASEBYTE CLAUSE (TIMES N 4)))
	    (PRINTOUT T
		N
		": (" TAG
		") "  (\GETBASEBYTE CLAUSE (ADD1 (TIMES N 4)))
		","   (\GETBASE CLAUSE (ADD1 (TIMES N 2)) )
		" "
		(if (EQ TAG symbol.tag.8) then
		    (\VAG2 0 (\GETBASE CLAUSE (ADD1 (TIMES N 2)) ))
		elseif (IGEQ TAG immed.tag.8) then
		    (\GETBASEPTR CLAUSE (TIMES N 2))
		else
		    "+"
		) T)
	)
	(if (EQ B 'R.retry.at) then
	    (SETQ CLAUSE (\GETBASEPTR CLAUSE 2))
	    (GO L)
	)
    )
)


;;  When a clause is retracted, and we finally remove it from the
;;  dead clause chain, this function is called to notify the Lisp
;;  garbage collector that the references it used to make are not
;;  there any more, and to say that this clause can be reclaimed.

(def.subr QP.FREE.CLAUSE (CLAUSE)
    (PROG (I)
	(if (NEQ (\GETBASE CLAUSE 6) 0) then
	    (RETURN (SHOULDNT "Clause freed twice"))
	)
	(\PUTBASE CLAUSE 6 55)	;; 55 is a random number
	(SETQ I (LLSH (\GETBASE CLAUSE 7) 1))
	;;  I is now the size of the clause in words
	(while (IGREATERP I 8)	;; not in header
	    (SETQ I (DIFFERENCE I 2))
	    (if (IGEQ (\GETBASE CLAUSE I) other.tag.16) then
		(\DELREF (\GETBASEPTR CLAUSE I))
	    )
	)
	;;  Now release the clause itself.
	(\DELREF CLAUSE)
    )
)



) STOP