home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / array.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  13.8 KB  |  429 lines
  1. ;;; -*- Package: SPARC -*-
  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.6 91/11/09 02:38:12 wlott Exp $
  11. ;;;
  12. ;;;    This file contains the SPARC definitions for array operations.
  13. ;;;
  14. ;;; Written by William Lott
  15. ;;;
  16. (in-package "SPARC")
  17.  
  18.  
  19. ;;;; Allocator for the array header.
  20.  
  21. (define-vop (make-array-header)
  22.   (:translate make-array-header)
  23.   (:policy :fast-safe)
  24.   (:args (type :scs (any-reg))
  25.      (rank :scs (any-reg)))
  26.   (:arg-types tagged-num tagged-num)
  27.   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
  28.   (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
  29.   (:results (result :scs (descriptor-reg)))
  30.   (:generator 0
  31.     (pseudo-atomic (ndescr)
  32.       (inst add header alloc-tn vm:other-pointer-type)
  33.       (inst add alloc-tn
  34.         (+ (* vm:array-dimensions-offset vm:word-bytes)
  35.            vm:lowtag-mask))
  36.       (inst add alloc-tn rank)
  37.       (inst and alloc-tn (lognot vm:lowtag-mask))
  38.       (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset)))
  39.       (inst sll ndescr ndescr vm:type-bits)
  40.       (inst or ndescr ndescr type)
  41.       (inst srl ndescr ndescr 2)
  42.       (storew ndescr header 0 vm:other-pointer-type))
  43.     (move result header)))
  44.  
  45.  
  46. ;;;; Additional accessors and setters for the array header.
  47.  
  48. (defknown lisp::%array-dimension (t fixnum) fixnum
  49.   (flushable))
  50. (defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
  51.   ())
  52.  
  53. (define-vop (%array-dimension word-index-ref)
  54.   (:translate lisp::%array-dimension)
  55.   (:policy :fast-safe)
  56.   (:variant vm:array-dimensions-offset vm:other-pointer-type))
  57.  
  58. (define-vop (%set-array-dimension word-index-set)
  59.   (:translate lisp::%set-array-dimension)
  60.   (:policy :fast-safe)
  61.   (:variant vm:array-dimensions-offset vm:other-pointer-type))
  62.  
  63.  
  64.  
  65. (defknown lisp::%array-rank (t) fixnum (flushable))
  66.  
  67. (define-vop (array-rank-vop)
  68.   (:translate lisp::%array-rank)
  69.   (:policy :fast-safe)
  70.   (:args (x :scs (descriptor-reg)))
  71.   (:temporary (:scs (non-descriptor-reg) :type random) temp)
  72.   (:results (res :scs (any-reg descriptor-reg)))
  73.   (:generator 6
  74.     (loadw temp x 0 vm:other-pointer-type)
  75.     (inst sra temp vm:type-bits)
  76.     (inst sub temp (1- vm:array-dimensions-offset))
  77.     (inst sll res temp 2)))
  78.  
  79.  
  80.  
  81. ;;;; Bounds checking routine.
  82.  
  83.  
  84. (define-vop (check-bound)
  85.   (:translate %check-bound)
  86.   (:policy :fast-safe)
  87.   (:args (array :scs (descriptor-reg))
  88.      (bound :scs (any-reg descriptor-reg))
  89.      (index :scs (any-reg descriptor-reg) :target result))
  90.   (:results (result :scs (any-reg descriptor-reg)))
  91.   (:vop-var vop)
  92.   (:save-p :compute-only)
  93.   (:generator 5
  94.     (let ((error (generate-error-code vop invalid-array-index-error
  95.                       array bound index)))
  96.       (inst cmp index bound)
  97.       (inst b :geu error)
  98.       (inst nop)
  99.       (move result index))))
  100.  
  101.  
  102.  
  103. ;;;; Accessors/Setters
  104.  
  105. ;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
  106. ;;; elements are represented in integer registers and are built out of
  107. ;;; 8, 16, or 32 bit elements.
  108.  
  109. (defmacro def-data-vector-frobs (type variant element-type &rest scs)
  110.   `(progn
  111.      (define-vop (,(intern (concatenate 'simple-string
  112.                     "DATA-VECTOR-REF/"
  113.                     (string type)))
  114.           ,(intern (concatenate 'simple-string
  115.                     (string variant)
  116.                     "-REF")))
  117.        (:note "inline array access")
  118.        (:variant vm:vector-data-offset vm:other-pointer-type)
  119.        (:translate data-vector-ref)
  120.        (:arg-types ,type positive-fixnum)
  121.        (:results (value :scs ,scs))
  122.        (:result-types ,element-type))
  123.      (define-vop (,(intern (concatenate 'simple-string
  124.                     "DATA-VECTOR-SET/"
  125.                     (string type)))
  126.           ,(intern (concatenate 'simple-string
  127.                     (string variant)
  128.                     "-SET")))
  129.        (:note "inline array store")
  130.        (:variant vm:vector-data-offset vm:other-pointer-type)
  131.        (:translate data-vector-set)
  132.        (:arg-types ,type positive-fixnum ,element-type)
  133.        (:args (object :scs (descriptor-reg))
  134.           (index :scs (any-reg zero immediate))
  135.           (value :scs ,scs))
  136.        (:results (result :scs ,scs))
  137.        (:result-types ,element-type))))
  138.  
  139. (def-data-vector-frobs simple-string byte-index
  140.   base-char base-char-reg)
  141. (def-data-vector-frobs simple-vector word-index
  142.   * descriptor-reg any-reg)
  143.  
  144. (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
  145.   positive-fixnum unsigned-reg)
  146. (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
  147.   positive-fixnum unsigned-reg)
  148. (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
  149.   unsigned-num unsigned-reg)
  150.  
  151.  
  152. ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
  153. ;;; and 4-bit vectors.
  154. ;;; 
  155.  
  156. (eval-when (compile eval)
  157.  
  158. (defmacro def-small-data-vector-frobs (type bits)
  159.   (let* ((elements-per-word (floor vm:word-bits bits))
  160.      (bit-shift (1- (integer-length elements-per-word))))
  161.     `(progn
  162.        (define-vop (,(symbolicate 'data-vector-ref/ type))
  163.      (:note "inline array access")
  164.      (:translate data-vector-ref)
  165.      (:policy :fast-safe)
  166.      (:args (object :scs (descriptor-reg))
  167.         (index :scs (unsigned-reg)))
  168.      (:arg-types ,type positive-fixnum)
  169.      (:results (value :scs (any-reg)))
  170.      (:result-types positive-fixnum)
  171.      (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
  172.      (:generator 20
  173.        (inst srl temp index ,bit-shift)
  174.        (inst sll temp 2)
  175.        (inst add temp (- (* vm:vector-data-offset vm:word-bytes)
  176.                  vm:other-pointer-type))
  177.        (inst ld result object temp)
  178.        (inst and temp index ,(1- elements-per-word))
  179.        (inst xor temp ,(1- elements-per-word))
  180.        ,@(unless (= bits 1)
  181.            `((inst sll temp ,(1- (integer-length bits)))))
  182.        (inst srl result temp)
  183.        (inst and result ,(1- (ash 1 bits)))
  184.        (inst sll value result 2)))
  185.        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
  186.      (:translate data-vector-ref)
  187.      (:policy :fast-safe)
  188.      (:args (object :scs (descriptor-reg)))
  189.      (:arg-types ,type (:constant index))
  190.      (:info index)
  191.      (:results (result :scs (unsigned-reg)))
  192.      (:result-types positive-fixnum)
  193.      (:temporary (:scs (non-descriptor-reg)) temp)
  194.      (:generator 15
  195.        (multiple-value-bind (word extra) (floor index ,elements-per-word)
  196.          (setf extra (logxor extra (1- ,elements-per-word)))
  197.          (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
  198.                   vm:other-pointer-type)))
  199.            (cond ((typep offset '(signed-byte 13))
  200.               (inst ld result object offset))
  201.              (t
  202.               (inst li temp offset)
  203.               (inst ld result object temp))))
  204.          (unless (zerop extra)
  205.            (inst srl result
  206.              (logxor (* extra ,bits) ,(1- elements-per-word))))
  207.          (unless (= extra ,(1- elements-per-word))
  208.            (inst and result ,(1- (ash 1 bits)))))))
  209.        (define-vop (,(symbolicate 'data-vector-set/ type))
  210.      (:note "inline array store")
  211.      (:translate data-vector-set)
  212.      (:policy :fast-safe)
  213.      (:args (object :scs (descriptor-reg))
  214.         (index :scs (unsigned-reg) :target shift)
  215.         (value :scs (unsigned-reg zero immediate) :target result))
  216.      (:arg-types ,type positive-fixnum positive-fixnum)
  217.      (:results (result :scs (unsigned-reg)))
  218.      (:result-types positive-fixnum)
  219.      (:temporary (:scs (non-descriptor-reg)) temp old offset)
  220.      (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
  221.      (:generator 25
  222.        (inst srl offset index ,bit-shift)
  223.        (inst sll offset 2)
  224.        (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
  225.                    vm:other-pointer-type))
  226.        (inst ld old object offset)
  227.        (inst and shift index ,(1- elements-per-word))
  228.        (inst xor shift ,(1- elements-per-word))
  229.        ,@(unless (= bits 1)
  230.            `((inst sll shift ,(1- (integer-length bits)))))
  231.        (unless (and (sc-is value immediate)
  232.             (= (tn-value value) ,(1- (ash 1 bits))))
  233.          (inst li temp ,(1- (ash 1 bits)))
  234.          (inst sll temp shift)
  235.          (inst not temp)
  236.          (inst and old temp))
  237.        (unless (sc-is value zero)
  238.          (sc-case value
  239.            (immediate
  240.         (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
  241.            (unsigned-reg
  242.         (inst and temp value ,(1- (ash 1 bits)))))
  243.          (inst sll temp shift)
  244.          (inst or old temp))
  245.        (inst st old object offset)
  246.        (sc-case value
  247.          (immediate
  248.           (inst li result (tn-value value)))
  249.          (t
  250.           (move result value)))))
  251.        (define-vop (,(symbolicate 'data-vector-set-c/ type))
  252.      (:translate data-vector-set)
  253.      (:policy :fast-safe)
  254.      (:args (object :scs (descriptor-reg))
  255.         (value :scs (unsigned-reg zero immediate) :target result))
  256.      (:arg-types ,type
  257.              (:constant index)
  258.              positive-fixnum)
  259.      (:info index)
  260.      (:results (result :scs (unsigned-reg)))
  261.      (:result-types positive-fixnum)
  262.      (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
  263.      (:generator 20
  264.        (multiple-value-bind (word extra) (floor index ,elements-per-word)
  265.          (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
  266.                   vm:other-pointer-type)))
  267.            (cond ((typep offset '(signed-byte 13))
  268.               (inst ld old object offset))
  269.              (t
  270.               (inst li offset-reg offset)
  271.               (inst ld old object offset-reg)))
  272.            (unless (and (sc-is value immediate)
  273.                 (= (tn-value value) ,(1- (ash 1 bits))))
  274.          (cond ((zerop extra)
  275.             (inst sll old ,bits)
  276.             (inst srl old ,bits))
  277.                (t
  278.             (inst li temp
  279.                   (lognot (ash ,(1- (ash 1 bits))
  280.                        (* (logxor extra
  281.                               ,(1- elements-per-word))
  282.                           ,bits))))
  283.             (inst and old temp))))
  284.            (sc-case value
  285.          (zero)
  286.          (immediate
  287.           (let ((value (ash (logand (tn-value value)
  288.                         ,(1- (ash 1 bits)))
  289.                     (* (logxor extra
  290.                            ,(1- elements-per-word))
  291.                        ,bits))))
  292.             (cond ((typep value '(signed-byte 13))
  293.                (inst or old value))
  294.               (t
  295.                (inst li temp value)
  296.                (inst or old temp)))))
  297.          (unsigned-reg
  298.           (inst sll temp value
  299.             (* (logxor extra ,(1- elements-per-word)) ,bits))
  300.           (inst or old temp)))
  301.            (if (typep offset '(signed-byte 13))
  302.            (inst st old object offset)
  303.            (inst st old object offset-reg)))
  304.          (sc-case value
  305.            (immediate
  306.         (inst li result (tn-value value)))
  307.            (t
  308.         (move result value)))))))))
  309.  
  310. ); eval-when (compile eval)
  311.  
  312. (def-small-data-vector-frobs simple-bit-vector 1)
  313. (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
  314. (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
  315.  
  316.  
  317. ;;; And the float variants.
  318. ;;; 
  319.  
  320. (define-vop (data-vector-ref/simple-array-single-float)
  321.   (:note "inline array access")
  322.   (:translate data-vector-ref)
  323.   (:policy :fast-safe)
  324.   (:args (object :scs (descriptor-reg))
  325.      (index :scs (any-reg)))
  326.   (:arg-types simple-array-single-float positive-fixnum)
  327.   (:results (value :scs (single-reg)))
  328.   (:temporary (:scs (non-descriptor-reg)) offset)
  329.   (:result-types single-float)
  330.   (:generator 5
  331.     (inst add offset index (- (* vm:vector-data-offset vm:word-bytes)
  332.                   vm:other-pointer-type))
  333.     (inst ldf value object offset)))
  334.  
  335.  
  336. (define-vop (data-vector-set/simple-array-single-float)
  337.   (:note "inline array store")
  338.   (:translate data-vector-set)
  339.   (:policy :fast-safe)
  340.   (:args (object :scs (descriptor-reg))
  341.      (index :scs (any-reg))
  342.      (value :scs (single-reg) :target result))
  343.   (:arg-types simple-array-single-float positive-fixnum single-float)
  344.   (:results (result :scs (single-reg)))
  345.   (:result-types single-float)
  346.   (:temporary (:scs (non-descriptor-reg)) offset)
  347.   (:generator 5
  348.     (inst add offset index
  349.       (- (* vm:vector-data-offset vm:word-bytes)
  350.          vm:other-pointer-type))
  351.     (inst stf value object offset)
  352.     (unless (location= result value)
  353.       (inst fmovs result value))))
  354.  
  355. (define-vop (data-vector-ref/simple-array-double-float)
  356.   (:note "inline array access")
  357.   (:translate data-vector-ref)
  358.   (:policy :fast-safe)
  359.   (:args (object :scs (descriptor-reg))
  360.      (index :scs (any-reg)))
  361.   (:arg-types simple-array-double-float positive-fixnum)
  362.   (:results (value :scs (double-reg)))
  363.   (:result-types double-float)
  364.   (:temporary (:scs (non-descriptor-reg)) offset)
  365.   (:generator 7
  366.     (inst sll offset index 1)
  367.     (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
  368.             vm:other-pointer-type))
  369.     (inst lddf value object offset)))
  370.  
  371. (define-vop (data-vector-set/simple-array-double-float)
  372.   (:note "inline array store")
  373.   (:translate data-vector-set)
  374.   (:policy :fast-safe)
  375.   (:args (object :scs (descriptor-reg))
  376.      (index :scs (any-reg))
  377.      (value :scs (double-reg) :target result))
  378.   (:arg-types simple-array-double-float positive-fixnum double-float)
  379.   (:results (result :scs (double-reg)))
  380.   (:result-types double-float)
  381.   (:temporary (:scs (non-descriptor-reg)) offset)
  382.   (:generator 20
  383.     (inst sll offset index 1)
  384.     (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
  385.             vm:other-pointer-type))
  386.     (inst stdf value object offset)
  387.     (unless (location= result value)
  388.       (inst fmovs result value)
  389.       (inst fmovs-odd result value))))
  390.  
  391. ;;; These vops are useful for accessing the bits of a vector irrespective of
  392. ;;; what type of vector it is.
  393. ;;; 
  394.  
  395. (define-vop (raw-bits word-index-ref)
  396.   (:note "raw-bits VOP")
  397.   (:translate %raw-bits)
  398.   (:results (value :scs (unsigned-reg)))
  399.   (:result-types unsigned-num)
  400.   (:variant 0 vm:other-pointer-type))
  401.  
  402. (define-vop (set-raw-bits word-index-set)
  403.   (:note "setf raw-bits VOP")
  404.   (:translate %set-raw-bits)
  405.   (:args (object :scs (descriptor-reg))
  406.      (index :scs (any-reg zero immediate))
  407.      (value :scs (unsigned-reg)))
  408.   (:arg-types * positive-fixnum unsigned-num)
  409.   (:results (result :scs (unsigned-reg)))
  410.   (:result-types unsigned-num)
  411.   (:variant 0 vm:other-pointer-type))
  412.  
  413.  
  414.  
  415. ;;;; Misc. Array VOPs.
  416.  
  417.  
  418. #+nil
  419. (define-vop (vector-word-length)
  420.   (:args (vec :scs (descriptor-reg)))
  421.   (:results (res :scs (any-reg descriptor-reg)))
  422.   (:generator 6
  423.     (loadw res vec clc::g-vector-header-words)
  424.     (inst niuo res res clc::g-vector-words-mask-16)))
  425.  
  426. (define-vop (get-vector-subtype get-header-data))
  427. (define-vop (set-vector-subtype set-header-data))
  428.  
  429.