From d4b84a20584d419152793f6d20b52f64b9b9e4a6 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 15 Jan 1993 01:33:53 +0000
Subject: [PATCH] Changed function-header-code-offset to function-code-offset.
 Added stuff for new var-alloc and fixed-alloc vops.

---
 compiler/hppa/cell.lisp | 100 ++++++++++++++++++----------------------
 1 file changed, 45 insertions(+), 55 deletions(-)

diff --git a/compiler/hppa/cell.lisp b/compiler/hppa/cell.lisp
index bb5fd8c6a..59f4c6f48 100644
--- a/compiler/hppa/cell.lisp
+++ b/compiler/hppa/cell.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.2 1992/10/28 00:32:43 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.3 1993/01/15 01:33:53 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -20,63 +20,34 @@
 (in-package "HPPA")
 
 
-;;;; Data object definition macros.
-
-(define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let ((lowtag (primitive-object-lowtag obj)))
-      (dolist (slot (primitive-object-slots obj))
-	(let* ((name (slot-name slot))
-	       (offset (slot-offset slot))
-	       (rest-p (slot-rest-p slot))
-	       (slot-opts (slot-options slot))
-	       (ref-trans (getf slot-opts :ref-trans))
-	       (ref-vop (getf slot-opts :ref-vop ref-trans))
-	       (set-trans (getf slot-opts :set-trans))
-	       (setf-function-p (and (listp set-trans)
-				     (= (length set-trans) 2)
-				     (eq (car set-trans) 'setf)))
-	       (setf-vop (getf slot-opts :setf-vop
-			       (when setf-function-p
-				 (intern (concatenate
-					  'simple-string
-					  "SET-"
-					  (string (cadr set-trans)))))))
-	       (set-vop (getf slot-opts :set-vop
-			      (if setf-vop nil set-trans))))
-	  (when ref-vop
-	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
-				(:variant ,offset ,lowtag)
-		      ,@(when ref-trans
-			  `((:translate ,ref-trans))))))
-	  (when (or set-vop setf-vop)
-	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
-					(error "Can't automatically generate ~
-					a setf VOP for :rest-p ~
-					slots: ~S in ~S"
-					       name
-					       (primitive-object-name obj)))
-				       (rest-p `(,set-vop slot-set))
-				       ((and set-vop setf-function-p)
-					(error "Setf functions (list ~S) must ~
-					use :setf-vops."
-					       set-trans))
-				       (set-vop `(,set-vop cell-set))
-				       (setf-function-p
-					`(,setf-vop cell-setf-function))
-				       (t
-					`(,setf-vop cell-setf)))
-		      (:variant ,offset ,lowtag)
-		      ,@(when set-trans
-			  `((:translate ,set-trans)))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+  (:args (object :scs (descriptor-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 1
+    (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results)
+  (:generator 1
+    (storew value object offset lowtag)))
 
 
 
 ;;;; Symbol hacking VOPs:
 
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+  (:variant symbol-value-slot other-pointer-type))
+
 ;;; Do a cell ref with an error check for being unbound.
 ;;;
 (define-vop (checked-cell-ref)
@@ -125,6 +96,9 @@
 
 ;;;; Fdefinition (fdefn) objects.
 
+(define-vop (fdefn-function cell-ref)
+  (:variant fdefn-function-slot other-pointer-type))
+
 (define-vop (safe-fdefn-function)
   (:args (object :scs (descriptor-reg) :target obj-temp))
   (:results (value :scs (descriptor-reg any-reg)))
@@ -149,8 +123,7 @@
     (load-type type function (- function-pointer-type))
     (inst addi (- function-header-type) type type)
     (inst comb := type zero-tn normal-fn)
-    (inst addi (- (ash function-header-code-offset word-shift)
-		  function-pointer-type)
+    (inst addi (- (ash function-code-offset word-shift) function-pointer-type)
 	  function lip)
     (inst li (make-fixup "closure_tramp" :foreign) lip)
     NORMAL-FN
@@ -231,6 +204,23 @@
   (descriptor-reg any-reg) * %set-funcallable-instance-info)
 
 
+(define-vop (closure-ref slot-ref)
+  (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+  (:variant closure-info-offset function-pointer-type))
+
+
+
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+  (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+  (:variant value-cell-value-slot other-pointer-type))
+
+
 
 ;;;; Structure hackery:
 
-- 
GitLab