;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;
;;;$Header: /ct/interp/dianapos.l,v 1.2 84/01/13 06:25:44 mark Exp $
;;;
;;;$Log:	/ct/interp/dianapos.l,v $
;;;Revision 1.2  84/01/13  06:25:44  mark
;;;This is the file which computes, at compile time, the coloring of
;;;the Diana nodes.  It emerged during Pass Five of the New Diana.
;;;It outputs a set of forms which, at load time, initialize the
;;;attribute slot positions and nodetype sizes.  The real work
;;;is done at compilation time.  It needs a compile-time-only file
;;;called diangraf and it also uses the gcolor stuff at compile-time
;;;only.
;;;
;;;Revision 1.1  84/01/04  06:30:16  mark
;;;Initial revision
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                           DIANAPOS                               ;;;
;;; Mark Miller                                            10-Jan-84 ;;;
;;;                                                                  ;;;
;;; This file computes the attribute positions for the Diana package ;;;
;;; using gcolor, Chatin's graph coloring algorithm.  More complete  ;;;
;;; documentation is in preparation.  ++Pass6                        ;;;
;;;                                                                  ;;;
;;; 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:                                             ;;;
;;;   Miller, December 1983.  The CTAda Diana Users Manual (online). ;;;
;;;   Ambler & Trawick, Chatin's Graph Coloring Algorithm as a       ;;;
;;;     Method for Assigning Positions to Diana Attributes.          ;;;
;;;     SIGPLAN NOTICES, V18, #2, February 1983.                     ;;;
;;;   Robertson & Miller, 1982.  The C*T Diana Virtual Machine.      ;;;
;;;   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. ;;;
;;;   Tartan Labs, 1982.  The Diana Reference Manual.                ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment assumes ctload and filemap)

(declare (ct_includef 'intrpdcl))

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

#$. (ct_load 'aip)			   ;AIP Macros pkg. 

#$. (ct_load 'compat)			   ;Compatibility Pkg.

#$. (ct_load 'ctio)			   ;Input-Output.

#$. (ct_load 'polly)			   ;Pure space stuff.

#$. (ct_load 'chunks)			   ;Hunk-like datatype.

;;; Since the attributes or nodetypes files might have been previously
;;; loaded but without full complr data, it may be necessary to use
;;; ct_reload instead of ct_load.  This mainly applies to the LISPM
;;; since the compiler and runtime environments live in the same world.

(eval-when (compile eval)
    (cond ((or (not (boundp '*diana_attributes*))
	       (null *diana_attributes*))
	   (ct_reload 'dianatts)))
    (cond ((or (not (boundp '*diana_nodetypes*))
	       (null *diana_nodetypes*))
	   (ct_reload 'dianods))))

(eval-when (load) (ct_load 'dianatts) (ct_load 'dianods))

(eval-when (compile eval) (ct_load 'gcolor))	  ;Chatin Graph Color Alg.

(eval-when (compile eval) (ct_load 'diangraf))

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

#+franz (declare (macros #+diana_debugging t
			 #-diana_debugging nil))  ;;Nota Bene!!

;;; The following specvar is a lookup table used only by functions
;;; within this file.  It does NOT need to go in intrpdcl.
(declare (special *diana_universal_attributes_table*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;      Assigning Fixed Slot Positions to Universal Attributes      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Universal attributes are assigned permanent fixed slot positions
;;; for all nodetypes.

#$.
(let ((i -1))					   ;i+1 is next free pos.
  (declare (fixnum i))
  (diana_attribute_position_set 'ct_id 0)          ;;Forcing the first few
  (diana_attribute_position_set 'ct_nodetype 1.)   ;;gives us a warm feeling.
  (diana_attribute_position_set 'ct_threadp 2.)
  (diana_attribute_position_set 'ct_cont 3.)
  (setq i 4.)					   ;;First free position.
   ;;(diana_attribute_position_set 'lx_srcpos 4.)
   ;;(diana_attribute_position_set 'lx_comments 5.)
   ;;(diana_attribute_position_set 'ct_generic_membership 6.)
   ;;(diana_attribute_position_set 'ct_bnl 7.)
   ;;(diana_attribute_position_set 'ct_pnl 8.)
   ;;(diana_attribute_position_set 'ct_prehook 9.)
   ;;(diana_attribute_position_set 'ct_posthook 10.)
  (mapc #'(lambda (att)
	    (cond
	      ((< (diana_attribute_position att) 0)
	       ;;; They are initialized to -1 above.
	       (diana_attribute_position_set att i)
	       (setq i (1+ i)))))
	*diana_universal_attributes*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;    Contingent Attribute Position Assignment Via Graph Coloring   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Contingent attributes are assigned slot positions based on the
;;; potential conflicts graph, constructed from the nodetype definitions.
;;; A graph coloring algorithm by Chatin is used to nearly-optimally
;;; assign the remaining positions, with an offset to allow for the
;;; universal slot positions.  The resulting nodes are about as "dense"
;;; as possible, given the speed constraint that a given attribute must
;;; always be located in the same position on any node that accepts it.

#+diana_debugging
                  ;;;;;;;;;;;;;
(declare (special *diana_graph*))
                  ;;;;;;;;;;;;;

(eval-when (compile eval)		           ;;Do NOT recompute
  (let ((graph  (diana_compute_conflicts_graph))   ;;colors at load-time!!
        (offset *diana_universals_count*))
    #+diana_debugging (setq *diana_graph* graph)   ;;So we can examine it.
    #+diana_debugging
    (or (check_consistency graph)	  ;;Always is {if above is correct}.
        (lose 'wta 'diana_assign_positions `("Graph is inconsistent.")))
    (mapc #'(lambda (a)
  	      (diana_attribute_position_set (car a) (+ offset (cadr a))))
           ;;;;;;;;;;;;;;;;;
	  (color_graph graph))))
           ;;;;;;;;;;;;;;;;;

(eval-when (compile eval)
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun diana_attribute_positions_init macro (form)
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (selfinsertmacro form
      `(progn 'compile
	      ,@(mapcar
		 #'(lambda (att)
		     `(diana_attribute_position_set
			',att
			,(diana_attribute_position att)))
		 *diana_attributes*)))))

(diana_attribute_positions_init)

(eval-when (compile eval)
         ;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun diana_nodetype_sizes_init macro (form)
         ;;;;;;;;;;;;;;;;;;;;;;;;;
    (selfinsertmacro form
     (let ((umax (1- *diana_universals_count*)))
       (declare (fixnum umax))
       `(progn 'compile
  	       ,@(mapcar
 		  #'(lambda (nodtyp)
		      `(diana_nodetype_size_set
		         ',nodtyp
		         ,(let ((siz umax))
			    (mapc
			      #'(lambda (att)
				  (let ((pos (diana_attribute_position att)))
				    (cond ((> pos siz) (setq siz pos)))))
			      (diana_contingent_attributes nodtyp))
			    (1+ siz))))
		  *diana_nodetypes*))))))

(diana_nodetype_sizes_init)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mapping from NodeType x Slot Position to Attribute Symbolic Name ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq *diana_universal_attributes_table*	;;Fast lookup table {hunk}.
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;        ;;Probably size 16 {maybe 8}.
      (make-pure-chunk *diana_universals_count*))

(mapc #'(lambda (att)
	  (chunk-put *diana_universal_attributes_table*
		     att
		     (diana_attribute_position att)))
      *diana_universal_attributes*)

       ;;;;;;;;;;;;;;;;;;;;;;
(defun diana_attribute_symbol (nodtyp pos)
       ;;;;;;;;;;;;;;;;;;;;;;
    (declare (fixnum pos))
    #+diana_debugging
    (and (or (< pos 0) (> pos 127.)) (lose 'wta 'diana_attribute_symbol))
    (cond
      ((< pos *diana_universals_count*)		   ;It's a univ. att.
       (chunk-get *diana_universal_attributes_table* pos))
      (t (do ((rst (diana_contingent_attributes nodtyp) (cdr rst)))
	     ((null rst)  nil)		   ;Unused slot
	   (cond ((= pos (diana_attribute_position (first rst)))
		  (return (first rst))))))))

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