close Warning: Error with navigation contributor "AccountModule"

source: trunk/dca-clozure.lisp

Last change on this file was 40, checked in by gz, 4 years ago

Fix %%load/%%store-low-24-bits to be compatible with lispworks version

File size: 11.0 KB
Line 
1;;;-*- Mode: Lisp -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; dca-clozure.lisp
6;; low-level accessors for disk-cache's, Clozure Common Lisp versions
7;;
8;; Portions Copyright © 2006 Clozure Associates
9;; Copyright © 1996 Digitool, Inc.
10;; Copyright © 1992-1995 Apple Computer, Inc.
11;; All rights reserved.
12;; Permission is given to use, copy, and modify this software provided
13;; that Digitool is given credit in all derivative works.
14;; This software is provided "as is". Digitool makes no warranty or
15;; representation, either express or implied, with respect to this software,
16;; its quality, accuracy, merchantability, or fitness for a particular
17;; purpose.
18;;
19
20(cl:eval-when (:execute)
21  ;; We lie a lot about the types of arrays.  The compiler is willing
22  ;; to trust us, the evaluator might not.
23  (cl:warn "This file must be compiled, it probably won't work evaluated."))
24
25(in-package :wood)
26
27;;(declaim (inline %%load-long %%load-unsigned-long))
28
29(defun %%load-long (array address)
30  (declare (type (simple-array (unsigned-byte 8) (*)) array)
31           (fixnum address)
32           (optimize (speed 3) (safety 0)))
33  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
34                       (aref array (the fixnum (1+ address)))))
35         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
36                      (aref array (the fixnum (+ address 3))))))
37    (declare (fixnum high-word low-word))
38    (when (logbitp 15 high-word)
39      (setq high-word (- high-word (expt 2 16))))
40    (+ (ash high-word 16) low-word)))
41
42(defun %%load-unsigned-long (array address)
43  (declare (type (simple-array (unsigned-byte 8) (*)) array)
44           (fixnum address)
45           (optimize (speed 3) (safety 0)))
46  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
47                       (aref array (the fixnum (1+ address)))))
48         (low-word (+  (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
49                       (aref array (the fixnum (+ address 3))))))
50    (declare (fixnum high-word low-word))
51    (+ (ash high-word 16) low-word)))
52
53(defun %%store-long (value array address)
54  (declare (type (simple-array (unsigned-byte 8) (*)) array)
55           (fixnum address)
56           (optimize (speed 3) (safety 0)))
57  (let ((low-word 0)
58        (high-word 0))
59    (if (typep value 'fixnum)
60      (locally (declare (fixnum low-word high-word value))
61        (setq low-word (logand value #xffff)
62              high-word (ash value -16)))
63      (setq low-word (logand value #xffff)
64            high-word (ash value -16)))
65    (setf (aref array address) (the fixnum (ash high-word -8))
66          (aref array (the fixnum (1+ address))) (the fixnum (logand high-word #xff))
67          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
68          (aref array (the fixnum (+ address 3))) (the fixnum (logand low-word #xff))))
69  value)
70
71(defun %%load-word (array index)
72  (declare (type (simple-array (unsigned-byte 8)  (*)) array)
73           (fixnum index)
74           (optimize (speed 3) (safety 0)))
75  (let ((res (+ (the fixnum (ash (aref array index) 8))
76                (aref array (the fixnum (1+ index))))))
77    (declare (fixnum res))
78    (if (logbitp 15 res)
79        (the fixnum (- res (expt 2 16)))
80        res)))
81
82(defun %%load-unsigned-word (array index)
83  (declare (type (simple-array (unsigned-byte 8)  (*)) array)
84           (fixnum index)
85           (optimize (speed 3) (safety 0)))
86  (the fixnum (+ (the fixnum (ash (aref array index) 8))
87                 (aref array (the fixnum (1+ index))))))
88
89(defun-inline %%store-word (value array index)
90  (locally (declare (type (simple-array (unsigned-byte 8)  (*)) array)
91                    (type fixnum index value)
92                    (optimize (speed 3) (safety 0)))
93    (setf (aref array index) (the fixnum (ash value -8))
94          (aref array (the fixnum (1+ index))) (logand value #xff))
95    value))
96
97
98;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99
100; Load a Wood fixnum returning a lisp fixnum
101(defun %%load-fixnum (array address)
102  (declare (type (simple-array (unsigned-byte 8) (*)) array)
103           (type fixnum address)
104           (optimize (speed 3) (safety 0)))
105  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
106                       (aref array (the fixnum (1+ address)))))
107         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
108                      (aref array (the fixnum (+ address 3))))))
109    (declare (fixnum high-word low-word))
110    (when (logbitp 15 high-word)
111      (setf high-word (- high-word (expt 2 16))))
112    (the fixnum
113         (+ (the fixnum (ash high-word (- 16 $tag-shift)))
114            (the fixnum (ash low-word (- $tag-shift)))))))
115
116(defun %%store-fixnum (value array address)
117  (declare (type (simple-array (unsigned-byte 8) (*)) array)
118           (type fixnum value address)
119           (optimize (speed 3) (safety 0)))
120  (let* ((high-word (the fixnum (ash value (- $tag-shift 16))))
121         (low-word (the fixnum
122                        (+ $t_fixnum
123                           (the fixnum
124                                (ash (the fixnum
125                                          (logand value
126                                                  (1- (ash 1 (- 16 $tag-shift)))))
127                                     $tag-shift))))))
128    (declare (fixnum high-word low-word))
129    (when (< high-word 0)
130      (setf high-word (the fixnum (+ high-word (expt 2 16)))))
131    (setf (aref array address) (the fixnum (ash high-word -8))
132          (aref array (the fixnum (1+ address))) (logand high-word #xff)
133          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
134          (aref array (the fixnum (+ address 3))) (logand low-word #xff))
135    value))
136
137; Load a Wood character returning a lisp character
138(defun %%load-character (array address)
139  (declare (type (simple-array (unsigned-byte 8) (*)) array)
140           (type fixnum address)
141           (optimize (speed 3) (safety 0)))
142  (let* ((high-word (+ (the fixnum (ash (aref array address) 8))
143                       (aref array (the fixnum (1+ address)))))
144         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ address 2))) 8))
145                      (aref array (the fixnum (+ address 3))))))
146    (declare (fixnum high-word low-word))
147    (code-char
148     (the fixnum (+ (the fixnum (ash high-word 8))
149                    (the fixnum (ash low-word -8)))))))
150
151(defun %%store-character (value array address)
152  (declare (type (simple-array (unsigned-byte 8) (*)) array)
153           (type fixnum address)
154           (type character value)
155           (optimize (speed 3) (safety 0)))
156  (let* ((code (char-code value))
157         (high-word (ash code -8))
158         (low-word (+ (the fixnum (ash (the fixnum (logand #xff code)) 8))
159                      $t_imm)))
160    (declare (fixnum code high-word low-word))
161    (setf (aref array address) (the fixnum (ash high-word -8))
162          (aref array (the fixnum (1+ address))) (logand high-word #xff)
163          (aref array (the fixnum (+ address 2))) (the fixnum (ash low-word -8))
164          (aref array (the fixnum (+ address 3))) (logand low-word -8))
165    value))
166
167
168(defun %%load-pointer (array address)
169  (declare (optimize (speed 3) (safety 0))
170           (fixnum address))
171  (let* ((tag-byte
172          (locally (declare (type (simple-array (unsigned-byte 8) (*)) array)
173                            (optimize (speed 3) (safety 0)))
174            (aref array (the fixnum (+ address 3)))))
175         (tag (logand tag-byte 7)))
176    (declare (fixnum tag-byte tag))
177    (case tag
178      (#.$t_fixnum
179       (values (%%load-fixnum array address) t))
180      (#.$t_imm
181       (values 
182        (ecase tag-byte
183          ($undefined (%unbound-marker))
184          ($illegal (ccl::%illegal-marker))
185          ($t_imm_char (%%load-character array address)))
186        t))
187      (t (%%load-unsigned-long array address)))))
188
189(defun %%store-pointer (value array address &optional imm?)
190  (cond ((not imm?)
191         (%%store-long value array address))
192        ((typep value 'fixnum) (%%store-fixnum value array address))
193        ((characterp value) (%%store-character value array address))
194        ((eq value (%unbound-marker))
195         (%%store-long $undefined array address))
196        ((eq value (ccl::%illegal-marker))
197         (%%store-long $illegal array address))
198        (t (error "~s is not a valid immediate" value)))
199  value)
200
201
202
203;;(declaim (inline %%load-low-24-bits %%store-low-24-bits))
204
205(defun %%load-low-24-bits (array index)
206  (declare (type (simple-array (unsigned-byte 8) (*)) array)
207           (type fixnum index)
208           (optimize (speed 3) (safety 0)))
209  (let* ((high-word (aref array (the fixnum (1+ index))))
210         (low-word (+ (the fixnum (ash (aref array (the fixnum (+ index 2))) 8))
211                      (aref array (the fixnum (+ index 3))))))
212    (declare (type fixnum high-word low-word))
213    (when (logbitp 15 high-word)
214      (setq high-word (- high-word (expt 2 16))))
215    (+ (ash high-word 16) low-word)))
216
217(defun %%store-low-24-bits (value array index)
218  (declare (type (simple-array (unsigned-byte 8) (*)) array)
219           (type fixnum index)
220           (optimize (speed 3) (safety 0)))
221  (let ((low-word 0)
222        (high-word 0)
223        (value (if (fixnump value) value (logand value #xFFFFFF))))
224    (declare (type fixnum low-word high-word value))
225    (setq low-word (logand value #xffff)
226          high-word (ash value -16))
227    (setf (aref array (the fixnum (1+ index))) (the fixnum (logand high-word #xff))
228          (aref array (the fixnum (+ index 2))) (the fixnum (ash low-word -8))
229          (aref array (the fixnum (+ index 3))) (the fixnum (logand low-word #xff))))
230  value)
231
232(defun (setf read-single-float) (value disk-cache address)
233  (unless (typep value 'single-float)
234    (setq value (require-type value 'single-float)))
235  #+64-bit-target
236  (let ((bits (ccl::single-float-bits value)))
237    (setf (read-pointer disk-cache address) bits))
238  #+32-bit-target
239  (store-bytes-as-byte-vector value disk-cache address 4 0)
240  value)
241
242(defun read-single-float (disk-cache address)
243    #+64-bit-target
244    (let ((bits (read-unsigned-long disk-cache address)))
245      (ccl::host-single-float-from-unsigned-byte-32 bits))
246    #+32-bit-target
247    (let ((float (ccl::%copy-float 0.0d0)))
248      (load-bytes-as-byte-vector disk-cache address 4 float 0)
249    float))
250
251(defun (setf read-double-float) (value disk-cache address)
252  (unless (typep value 'double-float)
253    (setq value (require-type value 'double-float)))
254  (store-bytes-as-byte-vector value disk-cache address 8
255                              #+64-bit-target 0
256                              #+32-bit-target 4)
257  value)
258
259(defun read-double-float (disk-cache address)
260  (let ((float (ccl::%copy-float 0.0d0)))
261    (load-bytes-as-byte-vector disk-cache address 8 float
262                               #+64-bit-target 0
263                               #+32-bit-target 4)
264    float))
265
266(defun uvector-bytes (uvector)
267  (let* ((count (ccl:uvsize uvector)))
268    (if (ccl::ivectorp uvector)
269        (ccl::subtag-bytes (ccl::typecode uvector) count)
270        (* count target::node-size))))
Note: See TracBrowser for help on using the repository browser.