;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; 
;;; $Header: /ct/interp/cache.l,v 1.8 84/04/11 22:43:08 penny Exp $
;;; $log: $
;;;

;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              cache                               ;;;
;;; Paul Robertson                                         10-4-83   ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(eval-when (compile load eval) (ct_load 'aip))	  ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg.

(eval-when (compile load eval) (ct_load 'ferec))

(eval-when (compile load eval) (ct_load 'ctflav)) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

(eval-when (compile load eval)
       ;;;;;;;;;;;;;;
(defun dynamic_mother macro(l)
       ;;;;;;;;;;;;;;

       (selfinsertmacro
	 l
	 `(or	
	    (nodestagerec%caller (assoc (diana_get ,(second l) 'ct_id)
					(ct_send *activation* 'nodestages)))
	    (car (diana_get ,(second l) 'ct_threadp)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun make_integer_from_object macro(l)
       ;;;;;;;;;;;;;;;;;;;;;;;;
   (selfinsertmacro l
       (let ((obj (second l)))
	 #+lispm `(%pointer ,obj)
	 #+franz `(maknum ,obj))))

       ;;;;;;;;;;;;;;
(defun cache_position macro (l)
       ;;;;;;;;;;;;;;
   (selfinsertmacro l
       (let ((ar (second l))
	     (pc (third l))
	     (id (fourth l)))
	 `(remainder (abs (+ (make_integer_from_object ,ar)
			(make_integer_from_object ,pc)
			(make_integer_from_object ,id)))
		     *ds_cache_size*))))

       ;;;;;;;;;;;;;
(defun find_in_cache macro (l)
       ;;;;;;;;;;;;;
   (selfinsertmacro l
       (let ((ar (second l))
	     (pc (third l))
	     (id (fourth l)))
	 #+franz `(arraycall t *ds_cache* (cache_position ,ar ,pc ,id))
	 #+lispm `(aref *ds_cache*        (cache_position ,ar ,pc ,id)))))

       ;;;;;;;;;;;;
(defun add_to_cache macro (l)
       ;;;;;;;;;;;;
   (selfinsertmacro l
       (let  ((ar (second l))
	      (pc (third l))
	      (dv (fourth l)))
	    `(let ((cache_pos 
		       (#+franz funcall #+lispm aref 
			   *ds_cache*
			   (cache_position ,ar ,pc (first ,dv)))))
		(%= (cache%activation cache_pos) ,ar)
		(%= (cache%node cache_pos) ,pc)
		(%= (cache%entry cache_pos) ,dv)))))
#|	 #+franz `(set (arrayref *ds_cache* (cache_position ,ar ,pc (first ,dv)))
		       (cache ,ar ,pc ,dv))
	 #+lispm `(aset (cache ,ar ,pc ,dv)
			*ds_cache* (cache_position ,ar ,pc (first ,dv)))
|#
       ;;;;;;;;;;;;;;;;;;
(defun recycle_cached_var macro (l)
       ;;;;;;;;;;;;;;;;;;
   (selfinsertmacro l
       (let ((n (second l))
	     (pc (third l)))
	 `(let ((cache_entry (find_in_cache *activation* ,pc ,n)))
	    (cond
	      ((and *cache_on*
		    cache_entry		  ;there is a cache_entry.
		    (eq ,pc       (cache%node  cache_entry))	  ;right node.
		    (eq ,n (first (cache%entry cache_entry))) 	  ;right name.
		    (eq *activation* (cache%activation cache_entry)))
	       (rplaca (cdr (cache%entry cache_entry)) nil) ;reset it to nil
	       (cache%entry cache_entry)) ;and recycle it.
	      (t (list ,n nil)))))))

       ;;;;;;;;;;;
(defun ds_find_var macro (l)
       ;;;;;;;;;;;
       (selfinsertmacro
	 l
	 (let ((n (second l))
	       (pc (third l)))
	   `(cond
	      ;; Is this variable in the cache ?
	      (
	       (let ((cache_entry (find_in_cache *activation* ,pc ,n)))
		 (cond
		   ((and *cache_on*
		      cache_entry	  ;there is a cache_entry.
		      (eq ,pc       (cache%node  cache_entry))	  ;right node.
		      (eq ,n (first (cache%entry cache_entry)))	;right name.
  		      (eq *activation* (cache%activation cache_entry)))  
		    (cache%entry cache_entry)))))
	      
	      ;; Get the variable the conventional way.
	      (t
	       (let ((dsv (assq ,n *dynamic_locals_alist*)))
		 (cond
		   ((null dsv)(setq dsv (ds_get_var_pair_aux ,n ,pc))))
		 (add_to_cache *activation* ,pc dsv)	  ; add to cache.
		 dsv))))))
)					  ;end of eval-when

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions -- 



       ;;;;;;;;;;
(defun ds_get_var(n pc)
       ;;;;;;;;;;

  (cadr (ds_find_var n pc)))			  ; and return the result.
	     
       ;;;;;;;;;;;;;;;
(defun ds_get_moms_var(n pc)
       ;;;;;;;;;;;;;;;
  (let ((pc (dynamic_mother pc))
	(*dynamic_locals_alist* nil))
    (cadr (ds_find_var n pc))))

       ;;;;;;;;;;
(defun ds_set_var(n pc v)
       ;;;;;;;;;;

  (rplaca (cdr (ds_find_var n pc)) v))

       ;;;;;;;;;;;;;;;
(defun ds_set_moms_var(n pc v)
       ;;;;;;;;;;;;;;;
  (let ((pc (dynamic_mother pc))
	(*dynamic_locals_alist* nil))
    (rplaca (cdr (ds_find_var n pc)) v)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				  eof				     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;