array.lisp 4.75 KB
Newer Older
1
;;; -*- Package: MIPS -*-
wlott's avatar
wlott committed
2 3
;;;
;;; **********************************************************************
wlott's avatar
wlott committed
4 5 6 7
;;; 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
8
  "$Header: src/assembly/mips/array.lisp $")
wlott's avatar
wlott committed
9
;;;
wlott's avatar
wlott committed
10
;;; **********************************************************************
wlott's avatar
wlott committed
11 12 13 14 15
;;;
;;;    This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;; 
16
(in-package "MIPS")
wlott's avatar
wlott committed
17

18
#-gengc
19 20 21 22 23 24
(define-assembly-routine (allocate-vector
			  (:policy :fast-safe)
			  (:translate allocate-vector)
			  (:arg-types positive-fixnum
				      positive-fixnum
				      positive-fixnum))
wlott's avatar
wlott committed
25
			 ((:arg type any-reg a0-offset)
26 27 28 29 30
			  (:arg length any-reg a1-offset)
			  (:arg words any-reg a2-offset)
			  (:res result descriptor-reg a0-offset)

			  (:temp ndescr non-descriptor-reg nl0-offset)
31
			  (:temp pa-flag non-descriptor-reg nl4-offset))
rtoy's avatar
rtoy committed
32
  ;; This is kinda sleazy, changing words like this.  But we can because
33 34 35 36 37 38 39
  ;; the vop thinks it is temporary.
  (inst addu words (+ (1- (ash 1 lowtag-bits))
		      (* vector-data-offset word-bytes)))
  (inst li ndescr (lognot lowtag-mask))
  (inst and words ndescr)
  (inst srl ndescr type word-shift)

wlott's avatar
wlott committed
40
  (pseudo-atomic (pa-flag)
41
    (inst or result alloc-tn other-pointer-type)
wlott's avatar
wlott committed
42
    (inst addu alloc-tn words)
wlott's avatar
wlott committed
43 44
    (storew ndescr result 0 other-pointer-type)
    (storew length result vector-length-slot other-pointer-type)))
45 46 47 48 49


;;;; Hash primitives

(define-assembly-routine (sxhash-simple-string
wlott's avatar
wlott committed
50 51 52 53
			  (:translate %sxhash-simple-string)
			  (:policy :fast-safe)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
54 55
			  (:res result any-reg a0-offset)

56 57
			  (:temp length any-reg a1-offset)

58 59 60
			  (:temp lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
61 62 63
			  (:temp byte non-descriptor-reg nl2-offset)
			  #-gengc
			  (:temp retaddr non-descriptor-reg nl3-offset))
64

wlott's avatar
wlott committed
65
  ;; These are needed after we jump into sxhash-simple-substring.
66
  (progn result lip accum data byte #-gengc retaddr)
wlott's avatar
wlott committed
67

68 69
  (inst j (make-fixup 'sxhash-simple-substring :assembly-routine))
  (loadw length string vector-length-slot other-pointer-type))
70 71

(define-assembly-routine (sxhash-simple-substring
wlott's avatar
wlott committed
72 73 74 75 76
			  (:translate %sxhash-simple-substring)
			  (:policy :fast-safe)
			  (:arg-types * positive-fixnum)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
77 78 79 80 81 82
			  (:arg length any-reg a1-offset)
			  (:res result any-reg a0-offset)

			  (:temp lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
83 84 85 86 87 88 89
			  (:temp byte non-descriptor-reg nl2-offset)
			  #-gengc
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; Save the return address
  #-gengc (inst subu retaddr lip code-tn)

90
  ;; Get a pointer to the data.
wlott's avatar
wlott committed
91
  (inst addu lip string
wlott's avatar
wlott committed
92
	(- (* vector-data-offset word-bytes) other-pointer-type))
wlott's avatar
wlott committed
93
  (inst b test)
94 95 96 97
  (move accum zero-tn)

  loop

wlott's avatar
wlott committed
98
  (inst and byte data #xff)
99 100 101 102 103 104
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 8)
wlott's avatar
wlott committed
105
  (inst and byte byte #xff)
106 107 108 109 110 111
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 16)
wlott's avatar
wlott committed
112
  (inst and byte byte #xff)
113 114 115 116 117 118 119 120 121 122 123
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  (inst srl byte data 24)
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

wlott's avatar
wlott committed
124
  (inst addu lip lip 4)
125 126 127

  test

128
  (inst addu length length (fixnumize -4))
129
  (inst lw data lip 0)
130
  (inst bgez length loop)
wlott's avatar
wlott committed
131
  (inst nop)
132

133
  (inst addu length length (fixnumize 3))
134
  (inst beq length zero-tn one-more)
135
  (inst addu length length (fixnumize -1))
136
  (inst beq length zero-tn two-more)
137
  (inst addu length length (fixnumize -1))
138
  (inst bne length zero-tn done)
wlott's avatar
wlott committed
139
  (inst nop)
140

141 142
  #+sgi  (inst srl byte data 8)
  #+pmax (inst srl byte data 16)
wlott's avatar
wlott committed
143
  (inst and byte byte #xff)
144 145 146 147 148 149 150
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  two-more

151 152
  #+sgi  (inst srl byte data 16)
  #+pmax (inst srl byte data 8)
wlott's avatar
wlott committed
153
  (inst and byte byte #xff)
154 155 156 157 158 159 160
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  one-more

161
  #+sgi (inst srl data data 24)
wlott's avatar
wlott committed
162
  (inst and byte data #xff)
163 164 165 166 167 168 169
  (inst xor accum accum byte)
  (inst sll byte accum 5)
  (inst srl accum accum 27)
  (inst or accum accum byte)

  done

170
  (inst sll result accum 5)
171 172 173 174
  (inst srl result result 3)

  ;; Restore the return address.
  #-gengc (inst addu lip code-tn retaddr))