home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / array.lisp < prev    next >
Encoding:
Text File  |  1992-01-30  |  20.6 KB  |  585 lines
  1. ;;; -*- Package: RT; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: array.lisp,v 1.10 92/01/29 20:22:12 ram Exp $
  11. ;;;
  12. ;;; This file contains the IBM RT definitions for array operations.
  13. ;;;
  14. ;;; Written by William Lott and Bill Chiles.
  15. ;;;
  16.  
  17. (in-package "RT")
  18.  
  19.  
  20.  
  21. ;;;; Allocator for the array header.
  22.  
  23. (define-vop (make-array-header)
  24.   (:translate make-array-header)
  25.   (:policy :fast-safe)
  26.   (:args (type :scs (any-reg descriptor-reg))
  27.      (rank :scs (any-reg descriptor-reg)))
  28.   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
  29.   (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
  30.   (:temporary (:sc word-pointer-reg) alloc)
  31.   (:results (result :scs (descriptor-reg)))
  32.   (:generator 0
  33.     (pseudo-atomic (ndescr)
  34.       ;; Take free pointer and make descriptor pointer for the result.  Just
  35.       ;; add in the three low-tag bits since alloc ptr is dual-word aligned,
  36.       ;; and its three low bits are zero.
  37.       (load-symbol-value alloc *allocation-pointer*)
  38.       (inst cal header alloc vm:other-pointer-type)
  39.       (inst cal alloc alloc
  40.         (+ (* vm:array-dimensions-offset vm:word-bytes)
  41.            vm:lowtag-mask))
  42.       ;; Rank is the dimensions as a fixnum which happens to be the number of
  43.       ;; bytes (by the machine's interpretation) we need to add to the alloc
  44.       ;; ptr.
  45.       (inst cas alloc rank alloc)
  46.       (inst nilo alloc (logand #xFFFF (lognot vm:lowtag-mask)))
  47.       (store-symbol-value alloc *allocation-pointer*)
  48.       (inst cal ndescr rank (fixnum (1- vm:array-dimensions-offset)))
  49.       ;; Shift the fixnum representation of the length, then OR in the fixnum
  50.       ;; rep of the type code, and then shift off the two extra fixnum zeros.
  51.       (inst sl ndescr vm:type-bits)
  52.       (inst o ndescr type)
  53.       (inst sr ndescr 2)
  54.       (storew ndescr header 0 vm:other-pointer-type))
  55.     (load-symbol-value ndescr *internal-gc-trigger*)
  56.     (inst tlt ndescr alloc)
  57.     (move result header)))
  58.  
  59.  
  60.  
  61. ;;;; Additional accessors and setters for the array header.
  62.  
  63. (defknown lisp::%array-dimension (t fixnum) fixnum
  64.   (flushable))
  65. (defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
  66.   ())
  67.  
  68. (define-vop (%array-dimension word-index-ref)
  69.   (:translate lisp::%array-dimension)
  70.   (:policy :fast-safe)
  71.   (:variant vm:array-dimensions-offset vm:other-pointer-type))
  72.  
  73. (define-vop (%set-array-dimension word-index-set)
  74.   (:translate lisp::%set-array-dimension)
  75.   (:policy :fast-safe)
  76.   (:variant vm:array-dimensions-offset vm:other-pointer-type))
  77.  
  78.  
  79.  
  80. (defknown lisp::%array-rank (t) fixnum (flushable))
  81.  
  82. ;;; ARRAY-RANK-VOP -- VOP.
  83. ;;;
  84. ;;; The length of the array header manifests the rank of the array.  We fetch
  85. ;;; the header word, extract the length, and subtract off the start of the
  86. ;;; dimension slots.
  87. ;;;
  88. (define-vop (array-rank-vop)
  89.   (:translate lisp::%array-rank)
  90.   (:policy :fast-safe)
  91.   (:args (x :scs (descriptor-reg)))
  92.   (:temporary (:scs (non-descriptor-reg) :type random :target res) temp)
  93.   (:results (res :scs (any-reg descriptor-reg)))
  94.   (:generator 6
  95.     (loadw temp x 0 vm:other-pointer-type)
  96.     (inst sr temp vm:type-bits)
  97.     (inst s temp (1- vm:array-dimensions-offset))
  98.     (inst sl temp 2)
  99.     (move res temp)))
  100.  
  101.  
  102.  
  103. ;;;; Bounds checking routine.
  104.  
  105. (define-vop (check-bound)
  106.   (:translate %check-bound)
  107.   (:policy :fast-safe)
  108.   (:args (array :scs (descriptor-reg))
  109.      (bound :scs (any-reg descriptor-reg))
  110.      (index :scs (any-reg descriptor-reg) :target result))
  111.   (:results (result :scs (any-reg descriptor-reg)))
  112.   (:vop-var vop)
  113.   (:save-p :compute-only)
  114.   (:generator 5
  115.     (let ((error (generate-error-code vop invalid-array-index-error
  116.                       array bound index)))
  117.       (inst c index bound)
  118.       (inst bnc :lt error)
  119.       (move result index))))
  120.  
  121.  
  122.  
  123. ;;;; 32-bit, 16-bit, and 8-bit vectors.
  124.  
  125. ;;; We build these variants on top of VOP's defined in memory.lisp.  These
  126. ;;; vectors' elements are represented in integer registers and are built out of
  127. ;;; 8, 16, or 32 bit elements.
  128.  
  129. (eval-when (compile eval)
  130. (defmacro def-data-vector-frobs (type variant element-type &rest scs)
  131.   `(progn
  132.      (define-vop (,(intern (concatenate 'simple-string
  133.                     "DATA-VECTOR-REF/"
  134.                     (string type)))
  135.           ,(intern (concatenate 'simple-string
  136.                     (string variant)
  137.                     "-REF")))
  138.        (:note "inline array access")
  139.        (:variant vm:vector-data-offset vm:other-pointer-type)
  140.        (:translate data-vector-ref)
  141.        (:arg-types ,type positive-fixnum)
  142.        (:results (value :scs ,scs))
  143.        (:result-types ,element-type))
  144.      (define-vop (,(intern (concatenate 'simple-string
  145.                     "DATA-VECTOR-SET/"
  146.                     (string type)))
  147.           ,(intern (concatenate 'simple-string
  148.                     (string variant)
  149.                     "-SET")))
  150.        (:note "inline array store")
  151.        (:variant vm:vector-data-offset vm:other-pointer-type)
  152.        (:translate data-vector-set)
  153.        (:arg-types ,type positive-fixnum ,element-type)
  154.        (:args (object :scs (descriptor-reg))
  155.           (index :scs (any-reg immediate))
  156.           (value :scs ,scs))
  157.        (:results (result :scs ,scs))
  158.        (:result-types ,element-type))))
  159. ) ;EVAL-WHEN
  160.  
  161. (def-data-vector-frobs simple-string byte-index
  162.   base-char base-char-reg)
  163. (def-data-vector-frobs simple-vector word-index
  164.   * descriptor-reg any-reg)
  165.  
  166. (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
  167.   positive-fixnum unsigned-reg)
  168. (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
  169.   positive-fixnum unsigned-reg)
  170. (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
  171.   unsigned-num unsigned-reg)
  172.  
  173.  
  174.  
  175. ;;;; Integer vectors with 1, 2, and 4 bit elements.
  176.  
  177. (eval-when (compile eval)
  178.  
  179. (defmacro def-small-data-vector-frobs (type bits)
  180.   (let* ((elements-per-word (floor vm:word-bits bits))
  181.      (bit-shift (1- (integer-length elements-per-word))))
  182.     `(progn
  183.        (define-vop (,(symbolicate 'data-vector-ref/ type))
  184.      (:note "inline array access")
  185.      (:translate data-vector-ref)
  186.      (:policy :fast-safe)
  187.      (:args (object :scs (descriptor-reg))
  188.         (index :scs (unsigned-reg)))
  189.      (:arg-types ,type positive-fixnum)
  190.      (:results (value :scs (any-reg)))
  191.      (:result-types positive-fixnum)
  192.      (:temporary (:scs (interior-reg)) lip)
  193.      (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
  194.      (:generator 20
  195.        (move temp index)
  196.        (inst sr temp ,bit-shift)
  197.        (inst sl temp 2)
  198.        (move lip object)
  199.        (inst a lip temp)
  200.        (loadw result lip vm:vector-data-offset vm:other-pointer-type)
  201.        (inst nilz temp index ,(1- elements-per-word))
  202.        (inst xil temp ,(1- elements-per-word))
  203.        ,@(unless (= bits 1)
  204.            `((inst sl temp ,(1- (integer-length bits)))))
  205.        (inst sr result temp)
  206.        (inst nilz result ,(1- (ash 1 bits)))
  207.        (move value result)
  208.        (inst sl value 2)))
  209.        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
  210.      (:translate data-vector-ref)
  211.      (:policy :fast-safe)
  212.      (:args (object :scs (descriptor-reg)))
  213.      (:arg-types ,type (:constant index))
  214.      (:temporary (:scs (interior-reg)) lip)
  215.      (:info index)
  216.      (:results (result :scs (unsigned-reg)))
  217.      (:result-types positive-fixnum)
  218.      (:generator 15
  219.        (multiple-value-bind (word extra) (floor index ,elements-per-word)
  220.          (setf extra (logxor extra (1- ,elements-per-word)))
  221.          (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
  222.                   vm:other-pointer-type)))
  223.            (cond ((typep offset '(signed-byte 16))
  224.               ;; Use the load with immediate offset if possible.
  225.               (inst l result offset))
  226.              (t
  227.               ;; Load the upper half of the offset in one instruction
  228.               ;; and add the lower half as an immediate offset in
  229.               ;; the load.  NOTE: if bit 15 is on, the load will sign-
  230.               ;; extend it, so we have to add 1 to the upper half now
  231.               ;; to counter the effect of the -1 from the sign-extension.
  232.               (inst cau lip object
  233.                 (if (logbitp 15 offset)
  234.                 (1+ (ash offset -16))
  235.                 (ash offset -16)))
  236.               (inst l result lip (logand #xFFFF offset)))))
  237.          (unless (zerop extra)
  238.            (inst sr result (* extra ,bits)))
  239.          (unless (= extra ,(1- elements-per-word))
  240.            (inst n result ,(1- (ash 1 bits)))))))
  241.        (define-vop (,(symbolicate 'data-vector-set/ type))
  242.      (:note "inline array store")
  243.      (:translate data-vector-set)
  244.      (:policy :fast-safe)
  245.      (:vop-var vop)
  246.      (:args (object :scs (descriptor-reg) :to (:eval 0))
  247.         ;; Normally, we would take the next arg in an unsigned-reg too.
  248.         ;; This caused a discrimination problem in the compiler for
  249.         ;; choosing a move function.  Since this VOP uses so many
  250.         ;; non-descriptor registers anyway which has been a hassle, we
  251.         ;; just removed unsigned-reg.
  252.         (index :scs (any-reg) :to (:eval 1))
  253.         (value :scs (unsigned-reg immediate)
  254.                :load-if (not (sc-is value unsigned-stack))
  255.                :target value-save))
  256.      (:arg-types ,type positive-fixnum positive-fixnum)
  257.      (:results (result :scs (unsigned-reg)))
  258.      (:result-types positive-fixnum)
  259.      (:temporary (:scs (unsigned-stack) :from (:argument 2)) value-save)
  260.      (:temporary (:scs (interior-reg)) lip)
  261.      (:temporary (:scs (non-descriptor-reg) :from (:argument 2)
  262.                :to (:result 0)) temp)
  263.      (:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:result 0))
  264.              old)
  265.      (:temporary (:scs (non-descriptor-reg) :from (:eval 1) :to (:result 0))
  266.              shift)
  267.      (:generator 25
  268.        (when (sc-is value unsigned-reg)
  269.          (storew value (current-nfp-tn vop) (tn-offset value-save)))
  270.        (move temp index)
  271.        (inst sr temp
  272.          (sc-case index
  273.            ;; In addition to dividing the index to map it to
  274.            ;; a number of words to skip, shift off the fixnum tag
  275.            ;; bits too.
  276.            (any-reg ,(+ bit-shift 2))
  277.            ;; No extraneous bits in this case.
  278.            (unsigned-reg ,bit-shift)))
  279.        (inst sl temp 2)
  280.        (move lip object)
  281.        (inst a lip temp)
  282.        (loadw old lip vm:vector-data-offset vm:other-pointer-type)
  283.        (sc-case index
  284.          (unsigned-reg
  285.           (inst nilz shift index ,(1- elements-per-word))
  286.           ,@(unless (= bits 1)
  287.           `((inst sl shift ,(1- (integer-length bits))))))
  288.          (any-reg
  289.           (inst nilz shift index ,(ash (1- elements-per-word) 2))
  290.           ,@(unless (= bits 4)
  291.           `((inst sr shift ,(- 3 (integer-length bits)))))))
  292.        (inst xil shift ,(1- elements-per-word))
  293.           
  294.        ;; Unless our immediate is all 1's, zero the destination bits.
  295.        (unless (and (sc-is value immediate)
  296.             (= (tn-value value) ,(1- (ash 1 bits))))
  297.          (inst li temp ,(1- (ash 1 bits)))
  298.          (inst sl temp shift)
  299.          (inst not temp)
  300.          (inst n old temp))
  301.        ;; Unless the value is zero, really deposit it.
  302.        (unless (and (sc-is value immediate)
  303.             (zerop (tn-value value)))
  304.          (sc-case value
  305.            (immediate
  306.         (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
  307.            ((unsigned-reg unsigned-stack)
  308.         (loadw temp (current-nfp-tn vop)
  309.                (tn-offset (if (sc-is value unsigned-stack)
  310.                       value
  311.                       value-save)))
  312.         (inst nilz temp ,(1- (ash 1 bits)))))
  313.          (inst sl temp shift)
  314.          (inst o old temp))
  315.        (storew old lip vm:vector-data-offset vm:other-pointer-type)
  316.        (sc-case value
  317.          (immediate
  318.           (inst li result (tn-value value)))
  319.          ((unsigned-reg unsigned-stack)
  320.           (loadw result (current-nfp-tn vop)
  321.              (tn-offset (if (sc-is value unsigned-stack)
  322.                     value
  323.                     value-save)))))))
  324.        (define-vop (,(symbolicate 'data-vector-set-c/ type))
  325.      (:translate data-vector-set)
  326.      (:policy :fast-safe)
  327.      (:args (object :scs (descriptor-reg))
  328.         (value :scs (unsigned-reg immediate) :target result))
  329.      (:arg-types ,type (:constant index) positive-fixnum)
  330.      (:temporary (:scs (interior-reg)) lip)
  331.      (:info index)
  332.      (:results (result :scs (unsigned-reg)))
  333.      (:result-types positive-fixnum)
  334.      (:temporary (:scs (non-descriptor-reg)) temp old)
  335.      (:generator 20
  336.        (multiple-value-bind (word extra) (floor index ,elements-per-word)
  337.          (setf extra (logxor extra (1- ,elements-per-word)))
  338.          (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
  339.                   vm:other-pointer-type)))
  340.            (cond ((typep offset '(signed-byte 16))
  341.               ;; Use the load with immediate offset if possible.
  342.               (inst l old offset))
  343.              (t
  344.               ;; Load the upper half of the offset in one instruction
  345.               ;; and add the lower half as an immediate offset in
  346.               ;; the load.  NOTE: if bit 15 is on, the load will sign-
  347.               ;; extend it, so we have to add 1 to the upper half now
  348.               ;; to counter the effect of the -1 from the sign-extension.
  349.               (inst cau lip object
  350.                 (if (logbitp 15 offset)
  351.                 (1+ (ash offset -16))
  352.                 (ash offset -16)))
  353.               (inst l old lip (logand #xFFFF offset)))))
  354.          ;; Unless our immediate is all 1's, zero the destination bits.
  355.          (unless (and (sc-is value immediate)
  356.               (= (tn-value value) ,(1- (ash 1 bits))))
  357.            (inst li temp
  358.              (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
  359.            (inst n old temp))
  360.          ;; Unless the value is zero, really deposit it.
  361.          (unless (and (sc-is value immediate)
  362.               (zerop (tn-value value)))
  363.            (sc-case value
  364.          (immediate
  365.           (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
  366.                     (* extra ,bits))))
  367.             ;; Isn't this test silly, or the otherwise branch doesn't
  368.             ;; work anyway????
  369.             (cond ((< value #x10000)
  370.                (inst oil old (logand #xFF value))
  371.                (inst oiu old (logand #xFF00 value)))
  372.               (t
  373.                (inst li temp value)
  374.                (inst o old temp)))))
  375.          (unsigned-reg
  376.           (move temp value)
  377.           ;; Shouldn't we do this to check the size of the value?
  378.           (inst nilz temp ,(1- (ash 1 bits)))
  379.           (inst sl temp (* extra ,bits))
  380.           (inst o old temp))))
  381.          (storew old object vm:vector-data-offset vm:other-pointer-type)
  382.          (sc-case value
  383.            (immediate
  384.         (inst li result (tn-value value)))
  385.            (unsigned-reg
  386.         (move result value)))))))))
  387.  
  388. ) ;EVAL-WHEN
  389.  
  390. (def-small-data-vector-frobs simple-bit-vector 1)
  391. (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
  392. (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
  393.  
  394.  
  395.  
  396. ;;;; Float vectors.
  397.  
  398. #-afpa(progn
  399. (define-vop (data-vector-ref/simple-array-mc68881-single-float)
  400.   (:note "inline array access")
  401.   (:translate data-vector-ref)
  402.   (:policy :fast-safe)
  403.   (:args (object :scs (descriptor-reg))
  404.      (index :scs (any-reg)))
  405.   (:arg-types simple-array-single-float positive-fixnum)
  406.   (:results (value :scs (mc68881-single-reg)))
  407.   (:result-types mc68881-single-float)
  408.   (:temporary (:sc sap-reg :from :eval) scratch)
  409.   (:temporary (:scs (interior-reg)) lip)
  410.   (:generator 20
  411.     (inst cas lip object index)
  412.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  413.              vm:other-pointer-type))
  414.     (inst mc68881-load value lip :single scratch)))
  415.  
  416. (define-vop (data-vector-set/simple-array-mc68881-single-float)
  417.   (:note "inline array store")
  418.   (:translate data-vector-set)
  419.   (:policy :fast-safe)
  420.   (:args (object :scs (descriptor-reg))
  421.      (index :scs (any-reg))
  422.      (value :scs (mc68881-single-reg) :target result))
  423.   (:arg-types simple-array-single-float positive-fixnum mc68881-single-float)
  424.   (:results (result :scs (mc68881-single-reg)))
  425.   (:result-types mc68881-single-float)
  426.   (:temporary (:scs (interior-reg)) lip)
  427.   (:temporary (:sc sap-reg :from :eval) scratch)
  428.   (:generator 20
  429.     (inst cas lip object index)
  430.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  431.              vm:other-pointer-type))
  432.     (inst mc68881-store value lip :single scratch)
  433.     (unless (location= result value)
  434.       (inst mc68881-move result value scratch))))
  435.  
  436. (define-vop (data-vector-ref/simple-array-mc68881-double-float)
  437.   (:note "inline array access")
  438.   (:translate data-vector-ref)
  439.   (:policy :fast-safe)
  440.   (:args (object :scs (descriptor-reg))
  441.      (index :scs (any-reg)))
  442.   (:arg-types simple-array-double-float positive-fixnum)
  443.   (:results (value :scs (mc68881-double-reg)))
  444.   (:result-types mc68881-double-float)
  445.   (:temporary (:scs (interior-reg)) lip)
  446.   (:temporary (:sc sap-reg :from :eval) scratch)
  447.   (:generator 20
  448.     (inst cas lip object index)
  449.     (inst cas lip lip index)
  450.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  451.              vm:other-pointer-type))
  452.     (inst mc68881-load value lip :double scratch)))
  453.  
  454. (define-vop (data-vector-set/simple-array-mc68881-double-float)
  455.   (:note "inline array store")
  456.   (:translate data-vector-set)
  457.   (:policy :fast-safe)
  458.   (:args (object :scs (descriptor-reg))
  459.      (index :scs (any-reg))
  460.      (value :scs (mc68881-double-reg) :target result))
  461.   (:arg-types simple-array-double-float positive-fixnum mc68881-double-float)
  462.   (:results (result :scs (mc68881-double-reg)))
  463.   (:result-types mc68881-double-float)
  464.   (:temporary (:scs (interior-reg)) lip)
  465.   (:temporary (:sc sap-reg :from :eval) scratch)
  466.   (:generator 20
  467.     (inst cas lip object index)
  468.     (inst cas lip lip index)
  469.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  470.              vm:other-pointer-type))
  471.     (inst mc68881-store value lip :double scratch)
  472.     (unless (location= result value)
  473.       (inst mc68881-move result value scratch))))
  474. )
  475.  
  476. #+afpa(progn
  477. (define-vop (data-vector-ref/simple-array-afpa-single-float)
  478.   (:note "inline array access")
  479.   (:translate data-vector-ref)
  480.   (:policy :fast-safe)
  481.   (:args (object :scs (descriptor-reg))
  482.      (index :scs (any-reg)))
  483.   (:arg-types simple-array-single-float positive-fixnum)
  484.   (:results (value :scs (afpa-single-reg)))
  485.   (:result-types afpa-single-float)
  486.   (:temporary (:sc sap-reg :from :eval) scratch)
  487.   (:temporary (:scs (interior-reg)) lip)
  488.   (:generator 20
  489.     (inst cas lip object index)
  490.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  491.              vm:other-pointer-type))
  492.     (inst afpa-load value lip :single scratch)
  493.     (inst afpa-noop scratch)))
  494.  
  495. (define-vop (data-vector-set/simple-array-afpa-single-float)
  496.   (:note "inline array store")
  497.   (:translate data-vector-set)
  498.   (:policy :fast-safe)
  499.   (:args (object :scs (descriptor-reg))
  500.      (index :scs (any-reg))
  501.      (value :scs (afpa-single-reg) :target result))
  502.   (:arg-types simple-array-single-float positive-fixnum afpa-single-float)
  503.   (:results (result :scs (afpa-single-reg)))
  504.   (:result-types afpa-single-float)
  505.   (:temporary (:scs (interior-reg)) lip)
  506.   (:temporary (:sc sap-reg :from :eval) scratch)
  507.   (:generator 20
  508.     (inst cas lip object index)
  509.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  510.              vm:other-pointer-type))
  511.     (inst afpa-store value lip :single scratch)
  512.     (inst afpa-noop scratch)
  513.     (unless (location= result value)
  514.       (inst afpa-move result value :single scratch))))
  515.  
  516. (define-vop (data-vector-ref/simple-array-afpa-double-float)
  517.   (:note "inline array access")
  518.   (:translate data-vector-ref)
  519.   (:policy :fast-safe)
  520.   (:args (object :scs (descriptor-reg))
  521.      (index :scs (any-reg)))
  522.   (:arg-types simple-array-double-float positive-fixnum)
  523.   (:results (value :scs (afpa-double-reg)))
  524.   (:result-types afpa-double-float)
  525.   (:temporary (:scs (interior-reg)) lip)
  526.   (:temporary (:sc sap-reg :from :eval) scratch)
  527.   (:generator 20
  528.     (inst cas lip object index)
  529.     (inst cas lip lip index)
  530.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  531.              vm:other-pointer-type))
  532.     (inst afpa-load value lip :double scratch)
  533.     (inst afpa-noop scratch)))
  534.  
  535. (define-vop (data-vector-set/simple-array-afpa-double-float)
  536.   (:note "inline array store")
  537.   (:translate data-vector-set)
  538.   (:policy :fast-safe)
  539.   (:args (object :scs (descriptor-reg))
  540.      (index :scs (any-reg))
  541.      (value :scs (afpa-double-reg) :target result))
  542.   (:arg-types simple-array-double-float positive-fixnum afpa-double-float)
  543.   (:results (result :scs (afpa-double-reg)))
  544.   (:result-types afpa-double-float)
  545.   (:temporary (:scs (interior-reg)) lip)
  546.   (:temporary (:sc sap-reg :from :eval) scratch)
  547.   (:generator 20
  548.     (inst cas lip object index)
  549.     (inst cas lip lip index)
  550.     (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
  551.              vm:other-pointer-type))
  552.     (inst afpa-store value lip :double scratch)
  553.     (inst afpa-noop scratch)
  554.     (unless (location= result value)
  555.       (inst afpa-move result value :double scratch))))
  556. )
  557.  
  558.  
  559. ;;;; Raw bits without regard to vector type.
  560.  
  561. (define-vop (raw-bits word-index-ref)
  562.   (:note "raw-bits VOP")
  563.   (:translate %raw-bits)
  564.   (:results (value :scs (unsigned-reg)))
  565.   (:result-types unsigned-num)
  566.   (:variant 0 vm:other-pointer-type))
  567.  
  568. (define-vop (set-raw-bits word-index-set)
  569.   (:note "setf raw-bits VOP")
  570.   (:translate %set-raw-bits)
  571.   (:args (object :scs (descriptor-reg))
  572.      (index :scs (any-reg immediate))
  573.      (value :scs (unsigned-reg)))
  574.   (:arg-types * positive-fixnum unsigned-num)
  575.   (:results (result :scs (unsigned-reg)))
  576.   (:result-types unsigned-num)
  577.   (:variant 0 vm:other-pointer-type))
  578.  
  579.  
  580.  
  581. ;;;; Vector subtype frobs.
  582.  
  583. (define-vop (get-vector-subtype get-header-data))
  584. (define-vop (set-vector-subtype set-header-data))
  585.