From ac9ab79f861b893b177dcb9b2d4adf37dfb54763 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 3 Nov 1990 03:20:53 +0000
Subject: [PATCH] Moved primitive-object and utility functions (fixnum,
 static-symbol-p, etc) into seperate files so they can be shared between vms.

---
 compiler/mips/parms.lisp | 488 ++-------------------------------------
 1 file changed, 24 insertions(+), 464 deletions(-)

diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
index dfbf2608e..451311df1 100644
--- a/compiler/mips/parms.lisp
+++ b/compiler/mips/parms.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: VM; Log: C.Log -*-
+;;; -*- Package: MIPS; Log: C.Log -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the Spice Lisp project at
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.78 1990/10/23 02:37:09 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.79 1990/11/03 03:20:53 wlott Exp $
 ;;;
 ;;;    This file contains some parameterizations of various VM
 ;;; attributes for the MIPS.  This file is separate from other stuff so 
@@ -18,7 +18,10 @@
 ;;; Converted to MIPS by William Lott.
 ;;;
 
-(in-package "VM")
+(in-package "MIPS")
+(use-package "C")
+
+(export '(word-bits byte-bits word-shift word-bytes))
 
 (export '(float-underflow-trap-bit float-overflow-trap-bit
 	  float-imprecise-trap-bit float-invalid-trap-bit
@@ -32,14 +35,25 @@
 ;;;
 (defconstant sc-number-limit 32)
 
-;;; The number of references that a TN must have to offset the overhead of
-;;; saving the TN across a call.
-;;;
-(defconstant register-save-penalty 3)
+(eval-when (compile eval load)
+
+(setf (backend-name *backend*) "PMAX")
+(setf (backend-version *backend*) "DECstation 3100/Mach 0.0")
+(setf (backend-fasl-file-type *backend*) "mips-fasl")
+(setf (backend-fasl-file-implementation *backend*)
+      pmax-fasl-file-implementation)
+(setf (backend-fasl-file-version *backend*) 1)
+(setf (backend-register-save-penalty *backend*) 3)
+(setf (backend-byte-order *backend*) :little-endian)
+
+); eval-when
+
 
 
 ;;;; Machine Architecture parameters:
 
+(eval-when (compile load eval)
+
 (defconstant word-bits 32
   "Number of bits per word where a word holds one lisp descriptor.")
 
@@ -52,21 +66,6 @@
 (defconstant word-bytes (/ word-bits byte-bits)
   "Number of bytes in a word.")
 
-(defparameter target-byte-order :little-endian
-  "The byte order of the target machine.  Should either be :big-endian
-  which has the MSB first (RT) or :little-endian which has the MSB last
-  (VAX).")
-
-(defparameter target-most-positive-fixnum (1- (ash 1 29))
-  "most-positive-fixnum in the target architecture.")
-
-(defparameter target-most-negative-fixnum (ash -1 29)
-  "most-negative-fixnum in the target architecture.")
-
-;;; ### This should be somewhere else.
-#-new-compiler
-(defconstant native-byte-order :big-endian
-  "The byte order we are running under.")
 
 (defconstant float-sign-shift 31)
 
@@ -92,6 +91,8 @@
 (defconstant double-float-digits
   (+ (byte-size double-float-significand-byte) word-bits 1))
 
+); eval-when
+
 
 ;;;; Description of the target address space.
 
@@ -101,110 +102,7 @@
 (defparameter target-static-space-start    #x04000000)
 (defparameter target-dynamic-space-start   #x06000000)
 
-
-;;;; Type definitions:
-
-(defconstant lowtag-bits 3
-  "Number of bits at the low end of a pointer used for type information.")
-
-(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
-  "Mask to extract the low tag bits from a pointer.")
-  
-(defconstant lowtag-limit (ash 1 lowtag-bits)
-  "Exclusive upper bound on the value of the low tag bits from a
-  pointer.")
-
-(defconstant type-bits 8
-  "Number of bits used in the header word of a data block for typeing.")
-
-(defconstant type-mask (1- (ash 1 type-bits))
-  "Mask to extract the type from a header word.")
-
-(defmacro pad-data-block (words)
-  `(logandc2 (+ (ash ,words vm:word-shift) lowtag-mask) lowtag-mask))
-
-
-(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))))
-
-;;; The main types.  These types are represented by the low three bits of the
-;;; pointer or immeditate object.
-;;; 
-(defenum (:suffix -type)
-  even-fixnum
-  function-pointer
-  other-immediate-0
-  list-pointer
-  odd-fixnum
-  structure-pointer
-  other-immediate-1
-  other-pointer)
-
-;;; The heap types.  Each of these types is in the header of objects in
-;;; the heap.
-;;; 
-(defenum (:suffix -type
-	  :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
-	  :step (ash 1 (1- lowtag-bits)))
-  bignum
-  ratio
-  single-float
-  double-float
-  complex
-  
-  simple-array
-  simple-string
-  simple-bit-vector
-  simple-vector
-  simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-32
-  simple-array-single-float
-  simple-array-double-float
-  complex-string
-  complex-bit-vector
-  complex-vector
-  complex-array
-  
-  code-header
-  function-header
-  closure-header
-  funcallable-instance-header
-  unused-function-header-1
-  unused-function-header-2
-  unused-function-header-3
-  closure-function-header
-  return-pc-header
-  value-cell-header
-  symbol-header
-  base-character
-  sap
-  unbound-marker
-  weak-pointer
-  structure-header)
+
 
 
 ;;;; Other non-type constants.
@@ -219,297 +117,6 @@
   error
   cerror)
 
-(defenum (:prefix vector- :suffix -subtype)
-  normal
-  structure
-  valid-hashing
-  must-rehash)
-
-
-
-;;;; Primitive data objects definition noise.
-
-
-(defstruct (slot
-	    (:constructor %make-slot
-			  (name docs rest-p length options)))
-  (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))
-
-(defun make-slot (name &rest options
-		       &key docs rest-p (length (if rest-p 0 1))
-		       &allow-other-keys)
-  (remf options :docs)
-  (remf options :rest-p)
-  (remf options :length)
-  (%make-slot name docs rest-p length options))
-
-(defstruct (primitive-object
-	    )
-  (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)))
-
-
-(defmacro define-primitive-object ((name &rest options
-					 &key header lowtag
-					 &allow-other-keys)
-				   &rest slots)
-  (setf options (copy-list options))
-  (remf options :header)
-  (remf options :lowtag)
-  (let ((prim-obj
-	 (make-primitive-object :name name
-				:header header
-				:lowtag lowtag
-				:options options
-				:slots (mapcar #'(lambda (slot)
-						   (if (atom slot)
-						       (make-slot slot)
-						       (apply #'make-slot
-							      slot)))
-					       slots))))
-    (collect ((forms) (exports))
-      (let ((offset (if (primitive-object-header prim-obj) 1 0))
-	    (variable-length nil))
-	(dolist (slot (primitive-object-slots prim-obj))
-	  (when variable-length
-	    (error "~S is anything after a :rest-p t slot." slot))
-	  (let* ((rest-p (slot-rest-p slot))
-		 (offset-sym
-		  (intern (concatenate 'simple-string
-				       (string name)
-				       "-"
-				       (string (slot-name slot))
-				       (if rest-p "-OFFSET" "-SLOT")))))
-	    (forms `(defconstant ,offset-sym ,offset
-		      ,@(when (slot-docs slot) (list (slot-docs slot)))))
-	    (setf (slot-offset slot) offset)
-	    (exports offset-sym)
-	    (incf offset (slot-length slot))
-	    (when rest-p (setf variable-length t))))
-	(setf (primitive-object-variable-length prim-obj) variable-length)
-	(unless variable-length
-	  (let ((size (intern (concatenate 'simple-string
-					   (string name)
-					   "-SIZE"))))
-	    (forms `(defconstant ,size ,offset
-		      ,(format nil
-			       "Number of slots used by each ~S~
-			       ~@[~* including the header~]."
-			       name header)))
-	    (exports size)))
-	(setf (primitive-object-size prim-obj) offset))
-      `(eval-when (compile load eval)
-	 (setf *primitive-objects*
-	       (cons ',prim-obj
-		     (delete ',name *primitive-objects*
-			     :key #'primitive-object-name)))
-	 (export ',(exports))
-	 ,@(forms)))))
-
-
-(defvar *primitive-objects* nil)
-
-(defmacro define-for-each-primitive-object ((var) &body body)
-  `(c::expand
-    `(progn
-       ,@(remove nil
-		 (mapcar #'(lambda (,var)
-			     ,@body)
-			 *primitive-objects*)))))
-
-
-
-;;;; The primitive objects themselves.
-
-
-(define-primitive-object (cons :lowtag list-pointer-type
-			       :alloc-trans cons)
-  (car :ref-vop car :ref-trans car
-       :setf-vop c::set-car :set-trans c::%rplaca
-       :init :arg)
-  (cdr :ref-vop cdr :ref-trans cdr
-       :setf-vop c::set-cdr :set-trans c::%rplacd
-       :init :arg))
-
-(define-primitive-object (bignum :lowtag other-pointer-type
-				 :header bignum-type
-				 :alloc-trans bignum::%allocate-bignum)
-  (digits :rest-p t :c-type "long"))
-
-(define-primitive-object (ratio :lowtag other-pointer-type
-				:header ratio-type
-				:alloc-vop c::make-ratio
-				:alloc-trans %make-ratio)
-  (numerator :ref-vop numerator :init :arg)
-  (denominator :ref-vop denominator :init :arg))
-
-(define-primitive-object (single-float :lowtag other-pointer-type
-				       :header single-float-type)
-  (value :c-type "float"))
-
-(define-primitive-object (double-float :lowtag other-pointer-type
-				       :header double-float-type)
-  (value :c-type "double" :length 2))
-
-(define-primitive-object (complex :lowtag other-pointer-type
-				  :header complex-type
-				  :alloc-vop c::make-complex
-				  :alloc-trans %make-complex)
-  (real :ref-vop realpart :init :arg)
-  (imag :ref-vop imagpart :init :arg))
-
-(define-primitive-object (array :lowtag other-pointer-type
-				:header t)
-  (fill-pointer :type index
-		:ref-trans %array-fill-pointer
-		:ref-known (c::flushable c::foldable)
-		:set-trans (setf %array-fill-pointer)
-		:set-known (c::unsafe))
-  (fill-pointer-p :type (member t nil)
-		  :ref-trans %array-fill-pointer-p
-		  :ref-known (c::flushable c::foldable)
-		  :set-trans (setf %array-fill-pointer-p)
-		  :set-known (c::unsafe))
-  (elements :type index
-	    :ref-trans %array-available-elements
-	    :ref-known (c::flushable c::foldable)
-	    :set-trans (setf %array-available-elements)
-	    :set-known (c::unsafe))
-  (data :type array
-	:ref-trans %array-data-vector
-	:ref-known (c::flushable c::foldable)
-	:set-trans (setf %array-data-vector)
-	:set-known (c::unsafe))
-  (displacement :type (or index null)
-		:ref-trans %array-displacement
-		:ref-known (c::flushable c::foldable)
-		:set-trans (setf %array-displacement)
-		:set-known (c::unsafe))
-  (displaced-p :type (member t nil)
-	       :ref-trans %array-displaced-p
-	       :ref-known (c::flushable c::foldable)
-	       :set-trans (setf %array-displaced-p)
-	       :set-known (c::unsafe))
-  (dimensions :rest-p t))
-
-(define-primitive-object (vector :lowtag other-pointer-type :header t)
-  (length :ref-trans c::vector-length
-	  :type index
-	  :ref-known (c::flushable c::foldable))
-  (data :rest-p t :c-type "unsigned long"))
-
-(define-primitive-object (code :lowtag other-pointer-type :header t)
-  (code-size :ref-vop c::code-code-size)
-  (entry-points :ref-vop c::code-entry-points
-		:set-vop c::set-code-entry-points)
-  (debug-info :type t
-	      :ref-trans di::code-debug-info
-	      :ref-known (c::flushable)
-	      :set-vop c::set-code-debug-info)
-  (constants :rest-p t))
-
-(define-primitive-object (function-header :lowtag function-pointer-type
-					  :header function-header-type)
-  (self :ref-vop c::function-self :set-vop c::set-function-self)
-  (next :ref-vop c::function-next :set-vop c::set-function-next)
-  (name :ref-vop c::function-name
-	:ref-known (c::flushable)
-	:ref-trans %function-header-name
-	:set-vop c::set-function-name)
-  (arglist :ref-vop c::function-arglist
-	   :ref-known (c::flushable)
-	   :ref-trans lisp::%function-header-arglist
-	   :set-vop c::set-function-arglist)
-  (type :ref-vop c::function-type
-	:ref-known (c::flushable)
-	:ref-trans lisp::%function-header-type
-	:set-vop c::set-function-type)
-  (code :rest-p t :c-type "unsigned char"))
-
-(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
-  (return-point :c-type "unsigned char" :rest-p t))
-
-(define-primitive-object (closure :lowtag function-pointer-type
-				  :header closure-header-type
-				  :alloc-vop c::make-closure)
-  (function :init :arg
-	    :ref-vop c::closure-function
-	    :ref-known (c::flushable)
-	    :ref-trans %closure-function)
-  (info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref))
-
-(define-primitive-object (value-cell :lowtag other-pointer-type
-				     :header value-cell-header-type
-				     :alloc-vop c::make-value-cell)
-  (value :set-vop c::value-cell-set
-	 :ref-vop c::value-cell-ref
-	 :init :arg))
-
-(define-primitive-object (symbol :lowtag other-pointer-type
-				 :header symbol-header-type)
-  (value :set-trans set
-	 :setf-vop set)
-  (function)
-  (raw-function-addr :c-type "char *")
-  (setf-function)
-  (plist :ref-trans symbol-plist
-	 :setf-vop c::set-symbol-plist
-	 :set-trans c::%sp-set-plist)
-  (name :ref-trans symbol-name)
-  (package :ref-trans symbol-package
-	   :setf-vop c::set-package))
-
-(define-primitive-object (sap :lowtag other-pointer-type
-			      :header sap-type)
-  (pointer :c-type "char *"))
-
-
-(define-primitive-object (weak-pointer :lowtag other-pointer-type
-				       :header weak-pointer-type
-				       :alloc-trans c::%make-weak-pointer)
-  (value :ref-trans c::%weak-pointer-value
-	 :ref-known (c::flushable)
-	 :set-trans (setf c::%weak-pointer-value)
-	 :set-known (c::unsafe)
-	 :init :arg)
-  (broken :ref-trans c::%weak-pointer-broken
-	  :ref-known (c::flushable)
-	  :set-trans (setf c::%weak-pointer-broken)
-	  :set-known (c::unsafe)
-	  :init :arg)
-  (next :c-type "struct weak_pointer *"))
-  
-
-;;; Other non-heap data blocks.
-
-(define-primitive-object (binding)
-  value
-  symbol)
-
-(define-primitive-object (unwind-block)
-  (current-uwp :c-type "struct unwind_block *")
-  (current-cont :c-type "lispobj *")
-  current-code
-  entry-pc)
-
-(define-primitive-object (catch-block)
-  (current-uwp :c-type "struct unwind_block *")
-  (current-cont :c-type "lispobj *")
-  current-code
-  entry-pc
-  tag
-  (previous-catch :c-type "struct catch_block *")
-  size)
 
 
 
@@ -587,43 +194,6 @@
     ))
 
 
-(defun static-symbol-p (symbol)
-  (member symbol static-symbols))
-
-(defun static-symbol-offset (symbol)
-  "Returns the byte offset of the static symbol Symbol."
-  (let ((posn (position symbol static-symbols)))
-    (unless posn (error "~S is not a static symbol." symbol))
-    (+ (* posn (pad-data-block symbol-size))
-       (pad-data-block (1- symbol-size))
-       other-pointer-type
-       (- list-pointer-type))))
-
-(defun offset-static-symbol (offset)
-  "Given a byte offset, Offset, returns the appropriate static symbol."
-  (multiple-value-bind
-      (n rem)
-      (truncate (+ offset list-pointer-type (- other-pointer-type)
-		   (- (pad-data-block (1- symbol-size))))
-		(pad-data-block symbol-size))
-    (unless (and (zerop rem) (<= 0 n (1- (length static-symbols))))
-      (error "Byte offset, ~D, is not correct." offset))
-    (elt static-symbols n)))
-
-
-
-;;;; Handy routine for making fixnums:
-
-(defun fixnum (num)
-  "Make a fixnum out of NUM.  (i.e. shift by two bits if it will fit.)"
-  (if (<= #x-20000000 num #x1fffffff)
-      ;; ### ASH doesn't work on negative bignums in the old compiler, but
-      ;; it we #-new-compiler this, the wrong defn will be used when we try
-      ;; to ncompile-file it in the bootstrap env.
-      (if (minusp num) (- (ash (- num) 2)) (ash num 2))
-      (error "~D is too big for a fixnum." num)))
-
-
 
 ;;;; Assembler parameters:
 
@@ -635,13 +205,3 @@
 
 ;;;; Other parameters:
 
-;;; The number representing the version of fasl files we are going to dump.
-;;;
-(defparameter target-fasl-file-implementation #.pmax-fasl-file-implementation)
-(defparameter target-fasl-file-version 1)
-
-(defparameter target-fasl-file-type "mips-fasl")
-
-;;; The version string for the implementation dependent code.
-;;;
-(defparameter vm-version "DECstation 3100/Mach 0.0")
-- 
GitLab