source: branches/portable/dca-clozure.lisp@ 31

;;;-*- Mode: Lisp -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; dca-ccl.lisp
;; low-level accessors for disk-cache's, Clozure Common Lisp versions
;;
;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info).
;; Copyright © 1996 Digitool, Inc.
;; Copyright © 1992-1995 Apple Computer, Inc.
;; All rights reserved.
;; Permission is given to use, copy, and modify this software provided
;; that Digitool is given credit in all derivative works.
;; This software is provided "as is". Digitool makes no warranty or
;; representation, either express or implied, with respect to this software,
;; its quality, accuracy, merchantability, or fitness for a particular
;; purpose.
;;

(cl:eval-when (:execute)
  ;; We lie a lot about the types of arrays.  The compiler is willing
  ;; to trust us, the evaluator might not.
  (cl:warn "This file must be compiled, it probably won't work evaluated."))

(in-package :wood)

;;(declaim (inline %%load-long %%load-unsigned-long))

(defun %%load-long (array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (fixnum address)
           (optimize (speed 3) (safety 0)))
  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
                       (aref array (the fixnum (1+ address)))))
         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
                      (aref array (the fixnum (+ address 3))))))
    (declare (fixnum high-word low-word))
    (when (logbitp 15 high-word)
      (setq high-word (- high-word (expt 2 16))))
    (+ (ash high-word 16) low-word)))

(defun %%load-unsigned-long (array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (fixnum address)
           (optimize (speed 3) (safety 0)))
  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
                       (aref array (the fixnum (1+ address)))))
         (low-word (+  (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
                       (aref array (the fixnum (+ address 3))))))
    (declare (fixnum high-word low-word))
    (+ (ash high-word 16) low-word)))

(defun %%store-long (value array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (fixnum address)
           (optimize (speed 3) (safety 0)))
  (let ((low-word 0)
        (high-word 0))
    (if (typep value 'fixnum)
      (locally (declare (fixnum low-word high-word value))
        (setq low-word (logand value #xffff)
              high-word (ash value -16)))
      (setq low-word (logand value #xffff)
            high-word (ash value -16)))
    (setf (aref array address) (the fixnum (ash high-word -8))
          (aref array (the fixnum (1+ address))) (the fixnum (logand high-word #xff))
          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
          (aref array (the fixnum (+ address 3))) (the fixnum (logand low-word #xff))))
  value)

(defun %%load-word (array index)
  (declare (type (simple-array (unsigned-byte 8)  (*)) array)
           (fixnum index)
           (optimize (speed 3) (safety 0)))
  (let ((res (+ (the fixnum (ash (aref array index) 8))
                (aref array (the fixnum (1+ index))))))
    (declare (fixnum res))
    (if (logbitp 15 res)
        (the fixnum (- res (expt 2 16)))
        res)))

(defun %%load-unsigned-word (array index)
  (declare (type (simple-array (unsigned-byte 8)  (*)) array)
           (fixnum index)
           (optimize (speed 3) (safety 0)))
  (the fixnum (+ (the fixnum (ash (aref array index) 8))
                 (aref array (the fixnum (1+ index))))))

(defun-inline %%store-word (value array index)
  (locally (declare (type (simple-array (unsigned-byte 8)  (*)) array)
                    (type fixnum index value)
                    (optimize (speed 3) (safety 0)))
    (setf (aref array index) (the fixnum (ash value -8))
          (aref array (the fixnum (1+ index))) (logand value #xff))
    value))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Load a Wood fixnum returning a lisp fixnum
(defun %%load-fixnum (array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (type fixnum address)
           (optimize (speed 3) (safety 0)))
  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
                       (aref array (the fixnum (1+ address)))))
         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
                      (aref array (the fixnum (+ address 3))))))
    (declare (fixnum high-word low-word))
    (when (logbitp 15 high-word)
      (setf high-word (- high-word (expt 2 16))))
    (the fixnum
         (+ (the fixnum (ash high-word (- 16 $tag-shift)))
            (the fixnum (ash low-word (- $tag-shift)))))))

(defun %%store-fixnum (value array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (type fixnum value address)
           (optimize (speed 3) (safety 0)))
  (let* ((high-word (the fixnum (ash value (- $tag-shift 16))))
         (low-word (the fixnum
                        (+ $t_fixnum
                           (the fixnum
                                (ash (the fixnum
                                          (logand value
                                                  (1- (ash 1 (- 16 $tag-shift)))))
                                     $tag-shift))))))
    (declare (fixnum high-word low-word))
    (when (< high-word 0)
      (setf high-word (the fixnum (+ high-word (expt 2 16)))))
    (setf (aref array address) (the fixnum (ash high-word -8))
          (aref array (the fixnum (1+ address))) (logand high-word #xff)
          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
          (aref array (the fixnum (+ address 3))) (logand low-word #xff))
    value))

; Load a Wood character returning a lisp character
(defun %%load-character (array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (type fixnum address)
           (optimize (speed 3) (safety 0)))
  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
                       (aref array (the fixnum (1+ address)))))
         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
                      (aref array (the fixnum (+ address 3))))))
    (declare (fixnum high-word low-word))
    (code-char
     (the fixnum (+ (the fixnum (ash high-word 8))
                    (the fixnum (ash low-word -8)))))))

(defun %%store-character (value array address)
  (declare (type (simple-array (unsigned-byte 8) (*)) array)
           (type fixnum address)
           (type character value)
           (optimize (speed 3) (safety 0)))
  (let* ((code (char-code value))
         (high-word (ash code -8))
         (low-word (+ (the fixnum (ash (the fixnum (logand #xff code)) 8))
                      $t_imm)))
    (declare (fixnum code high-word low-word))
    (setf (aref array address) (the fixnum (ash high-word -8))
          (aref array (the fixnum (1+ address))) (logand high-word #xff)
          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
          (aref array (the fixnum (+ address 3))) (logand low-word -8))
    value))


(defun %%load-pointer (array address)
  (declare (optimize (speed 3) (safety 0))
           (fixnum address))
  (let* ((tag-byte
          (locally (declare (type (simple-array (unsigned-byte 8) (*)) array)
                            (optimize (speed 3) (safety 0)))
            (aref array (the fixnum (+ address 3)))))
         (tag (logand tag-byte 7)))
    (declare (fixnum tag-byte tag))
    (case tag
      (#.$t_fixnum
       (values (%%load-fixnum array address) t))
      (#.$t_imm
       (values 
        (ecase tag-byte
          ($undefined (%unbound-marker))
          ($illegal (ccl::%illegal-marker))
          ($t_imm_char (%%load-character array address)))
        t))
      (t (%%load-unsigned-long array address)))))

(defun %%store-pointer (value array address &optional imm?)
  (cond ((not imm?)
         (%%store-long value array address))
        ((typep value 'fixnum) (%%store-fixnum value array address))
        ((characterp value) (%%store-character value array address))
        ((eq value (%unbound-marker))
         (%%store-long $undefined array address))
        ((eq value (ccl::%illegal-marker))
         (%%store-long $illegal array address))
        (t (error "~s is not a valid immediate" value)))
  value)



;;(declaim (inline %%load-low-24-bits %%store-low-24-bits))

(defun %%load-low-24-bits (array index)
  (declare (optimize (speed 3) (safety 0))
           (fixnum index))
  (let* ((word-index (ash index -1))
         (low-word
          (locally (declare (type (simple-array (unsigned-byte 16) (*)) array))
            (aref array (the fixnum (1+ word-index)))))
         (high-word
          (locally (declare (type (simple-array (unsigned-byte 8) (*)) array))
            (aref array (the fixnum (1+ index))))))
    (declare (fixnum word-index low-word high-word))
    (the fixnum
      (+ (the fixnum (ash high-word 16)) low-word))))

(defun %%store-low-24-bits (value array index)
  (declare (optimize (speed 3) (safety 0))
           (fixnum value index))
  (let* ((word-index (ash index -1))
         (low-word (logand value #xffff))
         (high-word (ash value -16)))
    (declare (fixnum word-index low-word high-word))
    (locally (declare (type (simple-array (unsigned-byte 16) (*)) array))
      (setf (aref array (the fixnum (1+ word-index))) low-word))
    (locally (declare (type (simple-array (unsigned-byte 8) (*)) array))
      (setf (aref array (the fixnum (1+ index))) high-word)))
  value)

(defun (setf read-single-float) (value disk-cache address)
  (unless (typep value 'single-float)
    (setq value (require-type value 'single-float)))
  #+64-bit-target
  (let ((bits (ccl::single-float-bits value)))
    (setf (read-pointer disk-cache address) bits))
  #+32-bit-target
  (store-bytes-as-byte-vector value disk-cache address 4 0)
  value)

(defun read-single-float (disk-cache address)
    #+64-bit-target
    (let ((bits (read-unsigned-long disk-cache address)))
      (ccl::host-single-float-from-unsigned-byte-32 bits))
    #+32-bit-target
    (let ((float (ccl::%copy-float 0.0d0)))
      (load-bytes-as-byte-vector disk-cache address 4 float 0)
    float))

(defun (setf read-double-float) (value disk-cache address)
  (unless (typep value 'double-float)
    (setq value (require-type value 'double-float)))
  (store-bytes-as-byte-vector value disk-cache address 8
                              #+64-bit-target 0
                              #+32-bit-target 4)
  value)

(defun read-double-float (disk-cache address)
  (let ((float (ccl::%copy-float 0.0d0)))
    (load-bytes-as-byte-vector disk-cache address 8 float
                               #+64-bit-target 0
                               #+32-bit-target 4)
    float))

(defun uvector-bytes (uvector)
  (let* ((count (ccl:uvsize uvector)))
    (if (ccl::ivectorp uvector)
        (ccl::subtag-bytes (ccl::typecode uvector) count)
        (* count target::node-size))))