;;; -*- Package: VM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: src/compiler/generic/vm-macs.lisp $")
;;;
;;; **********************************************************************
;;;
;;;    This file contains some macros and constants that are object-format
;;; specific or are used for defining the object format.
;;;
;;; Written by William Lott and Christopher Hoover.
;;; 
(in-package "VM")
(intl:textdomain "cmucl")



;;;; Other random stuff.

;;; PAD-DATA-BLOCK -- Internal Interface.
;;;
;;; This returns a form that returns a dual-word aligned number of bytes when
;;; given a number of words.
;;;
(defmacro pad-data-block (words)
  `(logandc2 (+ (ash ,words word-shift) #+amd64 15 #-amd64 lowtag-mask)
    #+amd64 15 #-amd64 lowtag-mask))

;;; DEFENUM -- Internal Interface.
;;;
(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
		   &rest identifiers)
  (let ((results nil)
	(index 0)
	(start (eval start))
	(step (eval step)))
    (dolist (id identifiers)
      (when id
	(multiple-value-bind
	    (root docs)
	    (if (consp id)
		(values (car id) (cdr id))
		(values id nil))
	  (push `(defconstant ,(intern (concatenate 'simple-string
						    (string prefix)
						    (string root)
						    (string suffix)))
		   ,(+ start (* step index))
		   ,@docs)
		results)))
      (incf index))
    `(eval-when (compile load eval)
       ,@(nreverse results))))


;;;; Primitive object definition stuff.

(export '(primitive-object primitive-object-p
	  primitive-object-name primitive-object-header
	  primitive-object-lowtag primitive-object-options
	  primitive-object-slots primitive-object-size
	  primitive-object-variable-length slot-name slot-docs slot-rest-p
	  slot-offset slot-length slot-options *primitive-objects*))


(defun remove-keywords (options keywords)
  (cond ((null options) nil)
	((member (car options) keywords)
	 (remove-keywords (cddr options) keywords))
	(t
	 (list* (car options) (cadr options)
		(remove-keywords (cddr options) keywords)))))

(defstruct (prim-object-slot
	    (:conc-name slot-)
	    (:constructor make-slot (name docs rest-p offset length options))
	    (:make-load-form-fun :just-dump-it-normally))
  (name nil :type symbol)
  (docs nil :type (or null simple-string))
  (rest-p nil :type (member t nil))
  (offset 0 :type fixnum)
  (length 1 :type fixnum)
  (options nil :type list))

(defstruct (primitive-object
	    (:make-load-form-fun :just-dump-it-normally))
  (name nil :type symbol)
  (header nil :type symbol)
  (lowtag nil :type symbol)
  (options nil :type list)
  (slots nil :type list)
  (size 0 :type fixnum)
  (variable-length nil :type (member t nil)))


(defvar *primitive-objects* nil)

(defun %define-primitive-object (primobj)
  (let ((name (primitive-object-name primobj)))
    (setf *primitive-objects*
	  (cons primobj
		(remove name *primitive-objects*
			:key #'primitive-object-name :test #'eq)))
    name))


(defmacro define-primitive-object
	  ((name &key header lowtag alloc-trans (type t))
	   &rest slot-specs)
  (collect ((slots) (exports) (constants) (forms) (inits))
    (let ((offset (if header 1 0))
	  (variable-length nil))
      (dolist (spec slot-specs)
	(when variable-length
	  (error (intl:gettext "No more slots can follow a :rest-p slot.")))
	(destructuring-bind
	    (slot-name &rest options
		       &key docs rest-p (length (if rest-p 0 1))
		       ((:type slot-type) t) init
		       (ref-known nil ref-known-p) ref-trans
		       (set-known nil set-known-p) set-trans
		       &allow-other-keys)
	    (if (atom spec) (list spec) spec)
	  (slots (make-slot slot-name docs rest-p offset length
			    (remove-keywords options
					     '(:docs :rest-p :length))))
	  (let ((offset-sym (symbolicate name "-" slot-name
					 (if rest-p "-OFFSET" "-SLOT"))))
	    (constants `(defconstant ,offset-sym ,offset
			  ,@(when docs (list docs))))
	    (exports offset-sym))
	  (when ref-trans
	    (when ref-known-p
	      (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
	    (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
	  (when set-trans
	    (when set-known-p
	      (forms `(defknown ,set-trans
				,(if (listp set-trans)
				     (list slot-type type)
				     (list type slot-type))
				,slot-type
			,set-known)))
	    (forms `(def-setter ,set-trans ,offset ,lowtag)))
	  (when init
	    (inits (cons init offset)))
	  (when rest-p
	    (setf variable-length t))
	  (incf offset length)))
      (unless variable-length
	(let ((size (symbolicate name "-SIZE")))
	  (constants `(defconstant ,size ,offset
			,(format nil
				 (intl:gettext "Number of slots used by each ~S~
				  ~@[~* including the header~].")
				 name header)))
	  (exports size)))
      (when alloc-trans
	(forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
			   ,lowtag ',(inits))))
      `(progn
	 (eval-when (compile load eval)
	   (export ',(exports))
	   (%define-primitive-object
	    ',(make-primitive-object :name name
				     :header header
				     :lowtag lowtag
				     :slots (slots)
				     :size offset
				     :variable-length variable-length))
	   ,@(constants))
	 ,@(forms)))))



;;;; reffer and setter definition stuff.

(in-package :c)

(export '(def-reffer def-setter def-alloc))

(defun %def-reffer (name offset lowtag)
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  #'(lambda (node block)
	      (ir2-convert-reffer node block name offset lowtag))))
  name)

(defmacro def-reffer (name offset lowtag)
  `(%def-reffer ',name ,offset ,lowtag))

(defun %def-setter (name offset lowtag)
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  (if (listp name)
	      #'(lambda (node block)
		  (ir2-convert-setfer node block name offset lowtag))
	      #'(lambda (node block)
		  (ir2-convert-setter node block name offset lowtag)))))
  name)

(defmacro def-setter (name offset lowtag)
  `(%def-setter ',name ,offset ,lowtag))

(defun %def-alloc (name words variable-length header lowtag inits)
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  (if variable-length
	      #'(lambda (node block)
		  (ir2-convert-variable-allocation node block name words header
						   lowtag inits))
	      #'(lambda (node block)
		  (ir2-convert-fixed-allocation node block name words header
						lowtag inits)))))
  name)

(defmacro def-alloc (name words variable-length header lowtag inits)
  `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))


;;;; Some general constant definitions:

(in-package "C")

(export '(fasl-file-implementations
	  pmax-fasl-file-implementation
	  sparc-fasl-file-implementation
	  rt-fasl-file-implementation
	  rt-afpa-fasl-file-implementation
	  x86-fasl-file-implementation
	  hppa-fasl-file-implementation
	  big-endian-fasl-file-implementation
	  little-endian-fasl-file-implementation
	  alpha-fasl-file-implementation
	  sgi-fasl-file-implementation
	  ppc-fasl-file-implementation
	  amd64-fasl-file-implementation))

;;; Constants for the different implementations.  These are all defined in
;;; one place to make sure they are all unique.

(defparameter fasl-file-implementations
  '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA"
	"Big-endian byte-code" "Little-endian byte-code" "Alpha" "SGI" "PPC" "AMD64"))
(defconstant pmax-fasl-file-implementation 1)
(defconstant sparc-fasl-file-implementation 2)
(defconstant rt-fasl-file-implementation 3)
(defconstant rt-afpa-fasl-file-implementation 4)
(defconstant x86-fasl-file-implementation 5)
(defconstant hppa-fasl-file-implementation 6)
(defconstant big-endian-fasl-file-implementation 7)
(defconstant little-endian-fasl-file-implementation 8)
(defconstant alpha-fasl-file-implementation 9)
(defconstant sgi-fasl-file-implementation 10)
(defconstant ppc-fasl-file-implementation 11)
(defconstant amd64-fasl-file-implementation 12)

;;; The maximum number of SCs in any implementation.
(defconstant sc-number-limit 32)
