1.0.9.13: copy the WRAPPER-SLOT-TABLE in FORCE-CACHE-FLUSHES
[sbcl.git] / src / assembly / hppa / array.lisp
1 (in-package "SB!VM")
2
3 (define-assembly-routine
4     (allocate-vector
5      (:policy :fast-safe)
6      (:translate allocate-vector)
7      (:arg-types positive-fixnum
8                  positive-fixnum
9                  positive-fixnum))
10     ((:arg type any-reg a0-offset)
11      (:arg length any-reg a1-offset)
12      (:arg words any-reg a2-offset)
13      (:res result descriptor-reg a0-offset)
14
15      (:temp ndescr non-descriptor-reg nl0-offset)
16      (:temp vector descriptor-reg a3-offset))
17   (pseudo-atomic ()
18     (move alloc-tn vector)
19     (inst dep other-pointer-lowtag 31 3 vector)
20     (inst addi (* (1+ vector-data-offset) n-word-bytes) words ndescr)
21     (inst dep 0 31 3 ndescr)
22     (inst add ndescr alloc-tn alloc-tn)
23     (inst srl type word-shift ndescr)
24     (storew ndescr vector 0 other-pointer-lowtag)
25     (storew length vector vector-length-slot other-pointer-lowtag))
26   (move vector result))
27
28
29 \f
30 ;;;; Hash primitives
31
32 ;;; FIXME: This looks kludgy bad and wrong.
33 #+sb-assembling
34 (defparameter *sxhash-simple-substring-entry* (gen-label))
35
36 (define-assembly-routine
37     (sxhash-simple-string
38      (:translate %sxhash-simple-string)
39      (:policy :fast-safe)
40      (:result-types positive-fixnum))
41     ((:arg string descriptor-reg a0-offset)
42      (:res result any-reg a0-offset)
43
44      (:temp length any-reg a1-offset)
45      (:temp accum non-descriptor-reg nl0-offset)
46      (:temp data non-descriptor-reg nl1-offset)
47      (:temp offset non-descriptor-reg nl2-offset))
48
49   (declare (ignore result accum data offset))
50
51   ;; Save the return address.
52   (inst b *sxhash-simple-substring-entry*)
53   (loadw length string vector-length-slot other-pointer-lowtag))
54
55 (define-assembly-routine
56     (sxhash-simple-substring
57      (:translate %sxhash-simple-substring)
58      (:policy :fast-safe)
59      (:arg-types * positive-fixnum)
60      (:result-types positive-fixnum))
61
62     ((:arg string descriptor-reg a0-offset)
63      (:arg length any-reg a1-offset)
64      (:res result any-reg a0-offset)
65
66      (:temp accum non-descriptor-reg nl0-offset)
67      (:temp data non-descriptor-reg nl1-offset)
68      (:temp offset non-descriptor-reg nl2-offset))
69
70   (emit-label *sxhash-simple-substring-entry*)
71
72   (inst li (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) offset)
73   (inst b test)
74   (move zero-tn accum)
75
76   LOOP
77   (inst xor accum data accum)
78   (inst shd accum accum 5 accum)
79
80   TEST
81   (inst ldwx offset string data)
82   (inst addib :>= (fixnumize -4) length loop)
83   (inst addi (fixnumize 1) offset offset)
84
85   (inst addi (fixnumize 4) length length)
86   (inst comb := zero-tn length done :nullify t)
87   (inst sub zero-tn length length)
88   (inst sll length 1 length)
89   (inst mtctl length :sar)
90   (inst shd zero-tn data :variable data)
91   (inst xor accum data accum)
92
93   DONE
94
95   (inst sll accum 5 result)
96   (inst srl result 3 result))