From 9f13f1a4232afd80bfc3a70fdb477c9b87a5a29f Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sun, 6 May 1990 05:25:50 +0000
Subject: [PATCH] Added {get,set}-header-data VOPs that used to be
 {get,set}-vector-subtype and where in array.lisp.  More things than just
 vectors have data in thoes bits.

---
 compiler/mips/system.lisp | 30 +++++++++++++++++++++++++++++-
 1 file changed, 29 insertions(+), 1 deletion(-)

diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp
index 085d6196a..78e483e81 100644
--- a/compiler/mips/system.lisp
+++ b/compiler/mips/system.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.10 1990/04/25 21:47:10 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.11 1990/05/06 05:25:50 wlott Exp $
 ;;;
 ;;;    MIPS VM definitions of various system hacking operations.
 ;;;
@@ -95,6 +95,34 @@
       (inst sll result ndescr 2))))
 
 
+(define-vop (get-header-data)
+  (:args (x :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :type random) temp)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 6
+    (loadw temp x 0 vm:other-pointer-type)
+    (inst sra temp temp vm:type-bits)
+    (inst sll res temp 2)))
+
+(define-vop (set-header-data)
+  (:args (x :scs (descriptor-reg) :target res)
+	 (data :scs (any-reg immediate)))
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg) :type random) t1 t2)
+  (:generator 6
+    (loadw t1 x 0 vm:other-pointer-type)
+    (inst li t2 vm:type-mask)
+    (inst and t1 t1 t2)
+    (sc-case data
+      (any-reg
+       (inst sll t2 data (- vm:type-bits 2))
+       (inst or t1 t1 t2))
+      (immediate
+       (inst or t1 t1 (ash (tn-value data) vm:type-bits))))
+    (storew t1 x 0 vm:other-pointer-type)
+    (move res x)))
+
+
 (define-vop (make-fixnum)
   (:args (ptr :scs (any-reg descriptor-reg)))
   (:results (res :scs (any-reg descriptor-reg)))
-- 
GitLab