array.lisp 3.89 KB
Newer Older
chiles's avatar
chiles committed
1 2 3 4
;;; -*- Package: RT -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
ram's avatar
ram committed
5 6 7
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/rt/array.lisp $")
ram's avatar
ram committed
9
;;;
chiles's avatar
chiles committed
10 11
;;; **********************************************************************
;;;
12
;;; $Header: src/assembly/rt/array.lisp $
chiles's avatar
chiles committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;

(in-package "RT")


(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)
			  (:temp alloc word-pointer-reg ocfp-offset)
			  (:temp vector descriptor-reg cname-offset))
  (pseudo-atomic (ndescr)
    (load-symbol-value alloc *allocation-pointer*)
    (inst cal vector alloc vm:other-pointer-type)
    (inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits))
			     (* vm:vector-data-offset vm:word-bytes)))
41
    (inst cas alloc alloc words)
chiles's avatar
chiles committed
42 43 44 45 46
    (inst li ndescr (lognot vm:lowtag-mask))
    (inst n alloc ndescr)
    (move ndescr type)
    (inst sr ndescr vm:word-shift)
    (storew ndescr vector 0 vm:other-pointer-type)
47 48
    (storew length vector vm:vector-length-slot vm:other-pointer-type)
    (store-symbol-value alloc *allocation-pointer*))
wlott's avatar
wlott committed
49 50
  (load-symbol-value ndescr *internal-gc-trigger*)
  (inst tlt ndescr alloc)
chiles's avatar
chiles committed
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
  (move result vector))



;;;; Hash primitives

(defparameter sxhash-simple-substring-entry (gen-label))

(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 accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nargs-offset)
			  (:temp temp non-descriptor-reg ocfp-offset))
69
  (declare (ignore result accum data temp))
70
  (inst bx sxhash-simple-substring-entry)
chiles's avatar
chiles committed
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
  (loadw length string vm:vector-length-slot vm:other-pointer-type))


(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 accum non-descriptor-reg nl0-offset)
			  (:temp data non-descriptor-reg nargs-offset)
			  (:temp temp non-descriptor-reg ocfp-offset)
			  (:temp lip interior-reg lip-offset))
  (emit-label sxhash-simple-substring-entry)
87
  ;; Get a stack slot to save the return-pc.
chiles's avatar
chiles committed
88
  (inst inc csp-tn word-bytes)
89 90 91 92 93 94
  ;; Save the return-pc as a byte offset from the component start, shifted
  ;; left to look like a fixnum.
  (inst s lip code-tn)
  (inst sl lip 2)
  (storew lip csp-tn (* -1 word-bytes))
  ;; Compute start of string as interior pointer.
chiles's avatar
chiles committed
95
  (inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type))
96
  (inst bx test)
chiles's avatar
chiles committed
97 98 99 100 101 102 103 104 105
  (inst li accum 0)
  LOOP
  (inst x accum data)
  (move temp accum)
  (inst sl temp 27)
  (inst sr accum 5)
  (inst o accum temp)
  (inst inc lip 4)
  TEST
106
  (inst s length (fixnumize 4))
107
  (inst bncx :lt loop)
chiles's avatar
chiles committed
108
  (loadw data lip)
109
  (inst a length (fixnumize 4))
chiles's avatar
chiles committed
110 111 112
  (inst bc :eq done)
  (inst neg length)
  (inst sl length 1)
113
  (inst nilz length #x1f)
chiles's avatar
chiles committed
114 115 116
  (inst sr data length)
  (inst x accum data)
  DONE
117 118 119 120 121 122 123 124 125 126
  ;; Give it fixnum low-tag bits.
  (inst sl accum 3)
  (move result accum)
  ;; Make it positive.
  (inst sr result 1)

  (loadw lip csp-tn (* -1 word-bytes))
  (inst dec csp-tn word-bytes)
  (inst sr lip 2)
  (inst cas lip lip code-tn))