array.lisp 3.15 KB
Newer Older
wlott's avatar
wlott committed
1 2 3 4 5 6 7
;;; -*- Package: HPPA -*-
;;;
;;; **********************************************************************
;;; 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/hppa/array.lisp $")
wlott's avatar
wlott committed
9 10 11 12 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 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
;;;
;;; **********************************************************************
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;
(in-package "HPPA")

(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 vector descriptor-reg a3-offset))
  (pseudo-atomic ()
    (move alloc-tn vector)
    (inst dep other-pointer-type 31 3 vector)
    (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr)
    (inst dep 0 31 3 ndescr)
    (inst add ndescr alloc-tn alloc-tn)
    (inst srl type word-shift ndescr)
    (storew ndescr vector 0 other-pointer-type)
    (storew length vector vector-length-slot other-pointer-type))
  (move vector result))



;;;; Hash primitives

#+assembler
(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 nl1-offset)
     (:temp offset non-descriptor-reg nl2-offset))

  (declare (ignore result accum data offset))

  ;; Save the return address.
  (inst b *sxhash-simple-substring-entry*)
  (loadw length string vector-length-slot 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 nl1-offset)
     (:temp offset non-descriptor-reg nl2-offset))

  (emit-label *sxhash-simple-substring-entry*)

  (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset)
  (inst b test)
  (move zero-tn accum)

  LOOP
  (inst xor accum data accum)
  (inst shd accum accum 5 accum)

  TEST
95
  (inst ldwx offset string data)
96 97
  (inst addib :>= (fixnumize -4) length loop)
  (inst addi (fixnumize 1) offset offset)
wlott's avatar
wlott committed
98

99
  (inst addi (fixnumize 4) length length)
100
  (inst comb := zero-tn length done :nullify t)
101
  (inst sub zero-tn length length)
wlott's avatar
wlott committed
102 103 104 105 106 107 108 109 110
  (inst sll length 1 length)
  (inst mtctl length :sar)
  (inst shd zero-tn data :variable data)
  (inst xor accum data accum)

  DONE

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