From: CSRG <csrg@ucbvax.Berkeley.EDU>
Date: Tue, 15 Dec 1987 10:10:08 +0000 (-0800)
Subject: BSD 4_3_Tahoe development
X-Git-Tag: BSD-4_3_Net_1^2~253
X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/f2b86c3bb4151e0096d5bd873c0808dad938b724

BSD 4_3_Tahoe development
Work on file usr/src/ucb/lisp/liszt/vector.l

Synthesized-from: CSRG/cd2/4.3tahoe
---

diff --git a/usr/src/ucb/lisp/liszt/vector.l b/usr/src/ucb/lisp/liszt/vector.l
new file mode 100644
index 0000000000..130888047b
--- /dev/null
+++ b/usr/src/ucb/lisp/liszt/vector.l
@@ -0,0 +1,483 @@
+(include-if (null (get 'chead 'version)) "../chead.l")
+(Liszt-file vector
+   "$Header: vector.l,v 1.12 87/12/15 17:10:04 sklower Exp $")
+
+;;; ----	v e c t o r			vector referencing
+;;;
+;;;				-[Fri Nov 11 22:35:50 1983 by jkf]-
+
+
+(defun cc-vset ()
+   ;;  Set a vector created via 'vector'.
+   (d-vset 'lisp))
+
+(defun cc-vref ()
+   ;;  Reference a vector created via 'vector'.
+   (d-vref 'lisp))
+
+(defun cc-vseti-byte ()
+   ;;  Set a vector created via 'vectori-byte'.
+   (d-vset 'byte))
+
+(defun cc-vrefi-byte ()
+   ;;  Reference a vector created via 'vectori-byte'.
+   (d-vref 'byte))
+
+(defun cc-vseti-word ()
+   ;;  Set a vector created via 'vectori-word'.
+   (d-vset 'word))
+
+(defun cc-vrefi-word ()
+   ;;  Reference a vector created via 'vectori-word'.
+   (d-vref 'word))
+
+(defun cc-vseti-long ()
+   ;;  Set a vector created via 'vectori-long'.
+   (d-vset 'long))
+
+(defun cc-vrefi-long ()
+   ;;  Reference a vector created via 'vectori-long'.
+   (d-vref 'long))
+
+;--- d-vset :: handle all types of vset's
+(defun d-vset (type)
+   ;;  Generic vector store.  Type is either 'lisp', 'byte', 'word',
+   ;; or 'long'.
+   (let ((vect (cadr v-form))
+	 (index (caddr v-form))
+	 (val (cadddr v-form))
+	 (vect-addr) (index-addr)
+	 (vect-val) (fetchval)
+	 (temp) (size)
+	 (vec-reg #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
+	 (val-reg #+(or for-vax for-tahoe) 'r1 #+for-68k 'd1)
+	 (index-reg '#.fixnum-reg)
+	 (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
+	 (temp-areg #+(or for-vax for-tahoe) 'bogus! #+for-68k 'a1)
+	 (oklab (d-genlab))
+	 (needlowcheck t))		; t if must check lower index bounds
+
+       #+for-68k (d-regused '#.fixnum-reg)
+       (makecomment `(doing vec set type ,type))
+       (if (fixp index)
+	   then (if (<& index 0)
+		    then (comp-err "vector index less than 0 " v-form))
+		(setq needlowcheck nil))
+
+       ; Compute the value to be stored...
+       ;
+       ; If we are doing an immediate vector, then get the value
+       ; instead of the boxed fixnum (in the case of byte), or
+       ; word/long.
+       (if (null (eq 'lisp type)) then (setq val `(cdr ,val)))
+
+       (if (null (setq vect-val (d-simple val)))
+	   then (let ((g-loc val-reg) g-cc g-ret)
+		    (d-exp val))
+		(setq vect-val val-reg)
+	   else (setq vect-val (e-cvt vect-val)))
+
+       ; make sure that we are not going to clobber val-reg...
+       (if (not (and (d-simple vect) (d-simple index)))
+	   then ; val-reg could be clobbered when we do the
+		; fetching of the vector or index values
+		(setq fetchval t)
+		(e-move vect-val (e-cvt 'stack)))
+
+       ; Compute the index...
+       ;
+       (if (setq index-addr (d-simple index))
+	   then (let ((g-loc vec-reg) g-cc g-ret)
+		    (d-exp vect))
+		(setq vect-addr vec-reg)	; the vector op is in vec-reg
+		; we really want the cdr of index (the actual number).
+		; if we can do that simply, great.  otherwise we
+		; bring the index into index-reg and then do the cdr ourselves
+		(if (setq temp (d-simple `(cdr ,index)))
+		    then (d-move temp index-reg)
+		    else (d-move index-addr index-reg)
+			 #+(or for-vax for-tahoe)
+			 (e-move `(0 ,index-reg) index-reg)
+			 #+for-68k
+			 (progn
+			     (e-move index-reg 'a5)
+			     (e-move '(0 a5) index-reg)))
+		(setq index-addr index-reg)
+	   else ; the index isn't computable simply, so we must
+		; stack the vector location to keep it safe
+		(let ((g-loc 'stack) g-cc g-ret)
+		    (d-exp vect))
+		(push nil g-locs)
+		(incr g-loccnt)
+		; compute index's value into index-reg
+		(d-fixnumexp index)
+		; now put vector address into vec-reg
+		(d-move 'unstack vec-reg)
+		(decr g-loccnt)
+		(pop g-locs)
+		(setq vect-addr vec-reg
+		      index-addr index-reg)
+		; must be sure that the cc's reflect the value of index-reg
+		(e-tst index-reg))
+
+       ;   At this point, vect-addr (always vec-reg) contains the location of
+       ; the start of the vector,  index-addr (always index-reg) contains
+       ; the index value.
+       ;   The condition codes reflect the value of the index.
+       ; First we insure that the index is non negative
+       ; test must use a jmp in case the object file is large
+       ;
+       (if needlowcheck
+	   then (e-write2 #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl oklab)
+		(e-write2 'jmp 'vecindexerr)
+		(e-label oklab)
+		(setq oklab (d-genlab)))
+       ;; now, we compare against the size of the vector
+       ;; the size of the vector is in bytes, we may want to shift this
+       ;; to reflect the size in words or longwords, depending on the
+       ;; type of reference
+       (if (eq type 'byte)
+	   then ; can compare right away
+		(e-cmp index-addr `(-8 ,vect-addr))
+	   else ; shift size into temp-reg
+		(setq size (if (eq type 'word) then 1 else 2))
+		#+for-vax
+		    (e-write4 'ashl (concat '$- size)
+			      `(-8 ,vect-addr) temp-reg)
+		#+for-tahoe
+		    (e-write4 'shar (concat '$ size)
+			      `(-8 ,vect-addr) temp-reg)
+		#+for-68k
+		(progn
+		    (e-move `(-8 ,vect-addr) temp-reg)
+		    (e-write3 'asrl `($ ,size) temp-reg))
+		(e-cmp index-addr temp-reg)
+		(d-clearreg temp-reg))
+       ;; size is the number of objects, the index is 0 based so
+       ;; it must be less than the vector size
+       (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
+       (e-write2 'jmp 'vecindexerr)
+       (e-label oklab)
+
+       (if fetchval
+	   then ; unstack the value to store...
+		(e-move (e-cvt 'unstack) val-reg)
+		(setq vect-val val-reg))
+
+       ;; if we get here then the access is in bounds
+       (if (eq type 'lisp)
+	   then #+(or for-vax for-tahoe)
+		(e-move vect-val `(0 ,vect-addr ,index-addr))
+		#+for-68k
+		(progn
+		    (e-move index-addr temp-reg)
+		    (e-write3 'asll '($ 2) temp-reg)
+		    (e-add vect-addr temp-reg)
+		    (e-move temp-reg temp-areg)
+		    (e-move vect-val `(0 ,temp-areg)))
+		(if g-loc (e-move vect-val (e-cvt g-loc)))
+		(if g-cc then (d-handlecc))
+	   else (setq temp (cadr (assq type '((byte movb)
+					      (word movw)
+					      (long movl)))))
+		#+(or for-vax for-tahoe)
+		(e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
+		#+for-68k
+		(progn
+		    (e-move index-addr temp-reg)
+		    (caseq type
+			(word (e-write3 'asll '($ 1) temp-reg))
+			(long (e-write3 'asll '($ 2) temp-reg)))
+		    (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
+		    (if (eq type 'long)
+			then (e-write3 temp vect-val `(0 ,temp-areg))
+			else (e-move vect-val 'd1)
+			     (e-write3 temp 'd1 `(0 ,temp-areg))))
+		(if g-loc
+		    then (if (eq type 'byte)
+			     then ; all bytes values are within the fixnum
+				  ; range, we convert them to immediate
+				  ; fixum with ease.
+				  #+for-vax
+				  (progn
+				      (e-write4 'ashl '($ 2)
+						index-reg index-reg)
+				      (e-write3 'movab
+						`(5120 ,index-reg)
+						(e-cvt g-loc)))
+				  #+for-tahoe
+				  (progn
+				      (e-write4 'shal '($ 2)
+						index-reg index-reg)
+				      (e-write3 'movab
+						`(5120 ,index-reg)
+						(e-cvt g-loc)))
+				  #+for-68k
+				  (progn
+				      (e-move index-reg temp-reg)
+				      (e-write3 'asll '($ 2) temp-reg)
+				      (e-move temp-reg temp-areg)
+				      (e-move
+						(e-cvt '(fixnum 0))
+						temp-reg)
+				      (e-write3 'lea
+						`(% 0 ,temp-areg ,temp-reg)
+						temp-areg)
+				      (e-move
+						temp-areg
+						(e-cvt g-loc)))
+			     else ; must convert the hard way
+				  (e-call-qnewint)
+				  (d-clearreg)
+				  (if (not (eq g-loc 'reg))
+				      then (d-move 'reg g-loc)))
+			 ; result is always non nil
+			 (if (car g-cc) then (e-goto (car g-cc)))
+		 elseif (car g-cc) then (e-goto (car g-cc))))
+       (d-vectorindexcode)))
+
+;--- d-vref :: handle all types of vref's
+(defun d-vref (type)
+   ;;  Generic vector reference.  Type is either 'lisp', 'byte', 'word',
+   ;; or 'long'.
+   (let ((vect (cadr v-form))
+	 (index (caddr v-form))
+	 (vect-addr) (index-addr) (temp) (size)
+	 (vec-reg #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
+	 (index-reg '#.fixnum-reg)
+	 (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
+	 (temp-areg #+(or for-vax for-tahoe) 'rX #+for-68k 'a1)
+	 (oklab (d-genlab))
+	 (needlowcheck t))  ; t if must check lower index bounds
+
+       #+for-68k (d-regused '#.fixnum-reg)
+       (makecomment `(doing vec ref type ,type))
+       (if (fixp index)
+	   then (if (<& index 0)
+		    then (comp-err "vector index less than 0 " v-form))
+		(setq needlowcheck nil))
+
+       (if (setq index-addr (d-simple index))
+	   then (let ((g-loc vec-reg) g-cc g-ret)
+		    (d-exp vect))
+		(setq vect-addr vec-reg)	; the vector op is in vec-reg
+		; we really want the cdr of index (the actual number).
+		; if we can do that simply, great.  otherwise we
+		; bring the index into index-reg and then do the cdr ourselves
+		(if (setq temp (d-simple `(cdr ,index)))
+		    then (d-move temp index-reg)
+		    else (d-move index-addr index-reg)
+			 #+(or for-vax for-tahoe)
+			 (e-move `(0 ,index-reg) index-reg)
+			 #+for-68k
+			 (progn
+			     (e-move index-reg 'a5)
+			     (e-move '(0 a5) index-reg)))
+		(setq index-addr index-reg)
+	   else ; the index isn't computable simply, so we must
+		; stack the vector location to keep it safe
+		(let ((g-loc 'stack) g-cc g-ret)
+		    (d-exp vect))
+		(push nil g-locs)
+		(incr g-loccnt)
+		; compute index's value into index-reg
+		(d-fixnumexp index)
+		; now put vector address into vec-reg
+		(d-move 'unstack vec-reg)
+		(decr g-loccnt)
+		(pop g-locs)
+		(setq vect-addr vec-reg
+		      index-addr index-reg)
+		; must be sure that the cc's reflect the value of index-reg
+		(e-tst index-reg))
+       
+       ; at this point, vect-addr (always vec-reg) contains the location of
+       ; the start of the vector,  index-addr (always index-reg) contains
+       ; the index value.  the condition codes reflect the value of
+       ; the index
+       ; First we insure that the index is non negative
+       ; test must use a jmp in case the object file is large
+       (if needlowcheck
+	   then (e-write2 #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl oklab)
+		(e-write2 'jmp 'vecindexerr)
+		(e-label oklab)
+		(setq oklab (d-genlab)))
+
+       ; now, we compare against the size of the vector
+       ; the size of the vector is in bytes, we may want to shift this
+       ; to reflect the size in words or longwords, depending on the
+       ; type of reference
+       (if (eq type 'byte)
+	   then ; can compare right away
+		(e-cmp index-addr `(-8 ,vect-addr))
+	   else ; shift size into temp-reg
+		(setq size (if (eq type 'word) then 1 else 2))
+		#+for-vax
+		(e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
+		#+for-tahoe
+		(e-write4 'shar (concat '$ size) `(-8 ,vect-addr) temp-reg)
+		#+for-68k
+		(progn
+		    (e-move `(-8 ,vect-addr) temp-reg)
+		    (e-write3 'asrl `($ ,size) temp-reg))
+		(e-cmp index-addr temp-reg)
+		(d-clearreg temp-reg))
+       ; size is the number of objects, the index is 0 based so
+       ; it must be less than the vector size
+       (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
+       (e-write2 'jmp 'vecindexerr)
+       (e-label oklab)
+
+       ;; if we get here then the access is in bounds
+       (if g-loc
+	   then ; we care about the value.
+		; if the value is one of the fixnum types, then we
+		; move the value to index-reg so it can be fixnum converted
+		(if (eq type 'lisp)
+		    then #+(or for-vax for-tahoe)
+			 (e-move `(0 ,vect-addr ,index-addr)
+				   (e-cvt g-loc))
+			 #+for-68k
+			 (progn
+			     (e-move index-addr temp-reg)
+			     (e-write3 'asll '($ 2) temp-reg)
+			     (e-add vect-addr temp-reg)
+			     (e-move temp-reg temp-areg)
+			     (e-move `(0 ,temp-areg) (e-cvt g-loc)))
+			 (if g-cc then (d-handlecc))
+		    else #+(or for-vax for-tahoe)
+			 (progn
+			     (setq temp (cadr (assq type '((byte cvtbl)
+							   (word cvtwl)
+							   (long movl)))))
+			     (e-write3 temp
+				       `(0 ,vect-addr ,index-addr)
+				       index-reg))
+			 #+for-68k
+			 (progn
+			     (setq temp
+				   (cadr (assq type '((byte movb)
+						      (word movw)
+						      (long movl)))))
+			     (caseq type
+				    (word (e-write3 'asll '($ 1) index-reg))
+				    (long (e-write3 'asll '($ 2) index-reg)))
+			     (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
+				       temp-areg)
+			     (if (memq type '(byte word))
+				 then (e-write2 'clrl index-reg))
+			     (e-write3 temp `(0 ,temp-areg) index-reg))
+			 (if (eq type 'byte)
+			     then ; all bytes values are within the fixnum
+				  ; range, we convert them to immediate
+				  ; fixum with ease.
+				  #+for-vax
+				  (progn
+				      (e-write4 'ashl '($ 2)
+						index-reg index-reg)
+				      (e-write3 'movab
+						`(5120 ,index-reg)
+						(e-cvt g-loc)))
+				  #+for-tahoe
+				  (progn
+				      (e-write4 'shal '($ 2)
+						index-reg index-reg)
+				      (e-write3 'movab
+						`(5120 ,index-reg)
+						(e-cvt g-loc)))
+				  #+for-68k
+				  (progn
+				      (e-write3 'asll '($ 2) index-reg)
+				      (e-move index-reg temp-areg)
+				      (e-move
+						'($ _nilatom+0x1400)
+						temp-reg)
+				      (e-write3 'lea
+						`(% 0 ,temp-areg ,temp-reg)
+						temp-areg)
+				      (e-move
+						temp-areg
+						(e-cvt g-loc)))
+			     else ; must convert the hard way
+				  (e-call-qnewint)
+				  (d-clearreg)
+				  (if (not (eq g-loc 'reg))
+				      then (d-move 'reg g-loc)))
+			 ; result is always non nil
+			 (if (car g-cc) then (e-goto (car g-cc))))
+	elseif g-cc
+	     ; we dont care about the value, just whether it nil
+	   then (if (eq type 'lisp)
+		    then #+(or for-vax for-tahoe)
+			 (e-tst `(0 ,vect-addr ,index-addr))
+			 #+for-68k
+			 (progn
+			     (e-move index-addr temp-reg)
+			     (e-write3 'asll '($ 2) temp-reg)
+			     (e-add vect-addr temp-reg)
+			     (e-move temp-reg temp-areg)
+			     (e-cmpnil `(0 ,temp-areg)))
+			 (d-handlecc)
+		    else ; if fixnum, then it is always true
+			 (if (car g-cc) then (e-goto (car g-cc)))))
+       (d-vectorindexcode)))
+
+;--- d-vectorindexcode :: put out code to call the vector range error.
+; At this point the vector is in r0, the index an immediate fixnum in r5
+; we call the function int:vector-range-error with two arguments, the
+; vector and the index.
+;
+(defun d-vectorindexcode ()
+   (if (null g-didvectorcode)
+      then (let ((afterlab (d-genlab)))
+	      (e-goto afterlab)
+	      (e-label 'vecindexerr)
+	      (d-move #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0 'stack)
+	      (e-call-qnewint)
+	      (d-move 'reg 'stack)
+	      (d-calltran 'int:vector-range-error 2)
+	      ; never returns
+	      (e-label afterlab))
+	   (setq g-didvectorcode t)))
+
+
+;------------------------ vector access functions
+
+;--- cc-vectorp :: check for vectorness
+;
+(defun cc-vectorp nil
+  (d-typesimp (cadr v-form) #.(immed-const 18)))
+
+;--- cc-vectorip :: check for vectoriness
+;
+(defun cc-vectorip nil
+  (d-typesimp (cadr v-form) #.(immed-const 19)))
+
+;--- c-vsize :: extract vsize
+;
+(defun c-vsize nil
+   (d-vectorsize (cadr v-form) '2))
+
+(defun c-vsize-byte nil
+   (d-vectorsize (cadr v-form) '0))
+
+(defun c-vsize-word nil
+   (d-vectorsize (cadr v-form) '1))
+
+(defun d-vectorsize (form shift)
+   (let ((g-loc #+(or for-vax for-tahoe) 'reg #+for-68k 'a0)
+	 g-cc
+	 g-ret)
+       (d-exp form))
+   ; get size into `fixnum-reg' for fixnum boxing
+   (if (zerop shift)
+       then (e-move '(-8 #+(or for-vax for-tahoe) r0 #+for-68k a0) '#.fixnum-reg)
+       else #+for-vax
+	    (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
+	    #+for-tahoe
+	    (e-write4 'shar (concat '$ shift) '(-8 r0) '#.fixnum-reg)
+	    #+for-68k
+	    (progn
+		(e-move '(-8 a0) '#.fixnum-reg)
+		(e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
+   (e-call-qnewint))