array.lisp 5.04 KB
Newer Older
hallgren's avatar
hallgren committed
1
2
3
4
5
6
7
;;; -*- Package: ALPHA -*-
;;;
;;; **********************************************************************
;;; 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/alpha/array.lisp $")
hallgren's avatar
hallgren committed
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
;;;
;;; **********************************************************************
;;;
;;;    This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;; Conversion by Sean Hallgren
;;; 
(in-package "ALPHA")

(define-assembly-routine (allocate-vector
			  (:policy :fast-safe)
			  (:translate allocate-vector)
			  (:arg-types positive-fixnum
				      positive-fixnum
				      positive-fixnum))
			 ((:arg type any-reg a0-offset)
			  (: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))
rtoy's avatar
rtoy committed
31
  ;; This is kinda sleazy, changing words like this.  But we can because
hallgren's avatar
hallgren committed
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
  ;; the vop thinks it is temporary.
  (inst addq words (+ (1- (ash 1 lowtag-bits))
		      (* vector-data-offset word-bytes))
	words)
  (inst li (lognot lowtag-mask) ndescr)
  (inst and words ndescr words)
  (inst srl type word-shift ndescr)

  (pseudo-atomic ()
    (inst bis alloc-tn other-pointer-type result)
    (inst addq alloc-tn words alloc-tn)
    (storew ndescr result 0 other-pointer-type)
    (storew length result vector-length-slot other-pointer-type)))


;;;; Hash primitives

(define-assembly-routine (sxhash-simple-string
			  (:translate %sxhash-simple-string)
			  (:policy :fast-safe)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
			  (:res result any-reg a0-offset)

			  (:temp length any-reg a1-offset)

			  (:temp lip interior-reg lip-offset)
			  (:temp accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nl1-offset)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset)
			  (:temp temp1 non-descriptor-reg nl4-offset))

  ;; These are needed after we jump into sxhash-simple-substring.
  (progn result lip accum data byte  retaddr)

  (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1)
  (loadw length string vector-length-slot other-pointer-type)
  (inst jmp zero-tn temp1
	(make-fixup 'sxhash-simple-substring :assembly-routine)))

(define-assembly-routine (sxhash-simple-substring
			  (:translate %sxhash-simple-substring)
			  (:policy :fast-safe)
			  (:arg-types * positive-fixnum)
			  (:result-types positive-fixnum))
			 ((:arg string descriptor-reg a0-offset)
			  (: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)
			  (:temp byte non-descriptor-reg nl2-offset)
			  (:temp retaddr non-descriptor-reg nl3-offset))

  ;; Save the return address
  (inst subq lip code-tn retaddr)

  ;; Get a pointer to the data.
  (inst addq string
	(- (* vector-data-offset word-bytes) other-pointer-type)
	lip)
  (move zero-tn accum)
  (inst br zero-tn test)

  loop

  (inst and data #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)

  (inst srl data 8 byte)
  (inst and byte #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)

  (inst srl data 16 byte)
  (inst and byte #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)

  (inst srl data 24 byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)

  (inst addq lip 4 lip)

  test

134
  (inst subq length (fixnumize 4) length)
hallgren's avatar
hallgren committed
135
136
137
  (inst ldl data 0 lip)
  (inst bge length loop)

138
  (inst addq length (fixnumize 3) length)
hallgren's avatar
hallgren committed
139
  (inst beq length one-more)
140
  (inst subq length (fixnumize 1) length)
hallgren's avatar
hallgren committed
141
142
143
144
145
146
147
148
149
150
  (inst beq length two-more)
  (inst bne length done)

  (inst srl data 16 byte)
  (inst and byte #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)
151
  (inst addq length (fixnumize 1) length)
hallgren's avatar
hallgren committed
152
153
154

  two-more

155
  (inst subq length (fixnumize 1) length)
hallgren's avatar
hallgren committed
156
157
158
159
160
161
162
  (inst srl data 8 byte)
  (inst and byte #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)
163
  (inst addq length (fixnumize 1) length)
hallgren's avatar
hallgren committed
164
165
166

  one-more

167
  (inst subq length (fixnumize 1) length)
hallgren's avatar
hallgren committed
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
  (inst and data #xff byte)
  (inst xor accum byte accum)
  (inst sll accum 5 byte)
  (inst srl accum 27 accum)
  (inst mskll accum 4 accum)
  (inst bis accum byte accum)

  done

  (inst sll accum 5 result)
  (inst mskll result 4 result)
  (inst srl result 3 result)

  ;; Restore the return address.
  (inst addq code-tn retaddr lip))