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

Last change on this file since 31 was 12, checked in by wws, 10 years ago

Checkpoint. It builds in x8664 CCL, with lots of warnings. Not close to working yet.
File size: 9.3 KB
Line 
1;;;-*- Mode: Lisp -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; dca-lispworks.lisp
6;; low-level accessors for disk-cache's, lispworks versions
7;;
8;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info).
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(defun-inline %%load-long (byte-array address)
28 (declare (type (simple-array (unsigned-byte 8) (*)) byte-array)
29 (type fixnum address)
30 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
31 (sys:int32-to-integer
32 (sys:int32-logior
33 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum address)) 24)
34 (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16))
35 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8)
36 (aref byte-array (the fixnum (+ address 3)))))))
37
38(defun-inline %%load-unsigned-long (byte-array address)
39 (declare (type (simple-array (unsigned-byte 8) (*)) byte-array)
40 (type fixnum address)
41 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
42 (let* ((b0 (aref byte-array address))
43 (int (sys:int32-to-integer
44 (sys:int32-logior
45 (sys:int32-logior (sys:int32<< b0 24)
46 (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16))
47 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8)
48 (aref byte-array (the fixnum (+ address 3))))))))
49 (declare (type (unsigned-byte 8) b0))
50 (if (logbitp 7 b0)
51 (logand #xFFFFFFFF int)
52 int)))
53
54(defun %%store-long (value array address)
55 (declare (type (simple-array (unsigned-byte 8) (*)) array)
56 (type fixnum address)
57 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
58 (let ((int (sys:integer-to-int32 value)))
59 (declare (type sys:int32 int))
60 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 24))))
61 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16))))
62 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8))))
63 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int)))))
64
65(defun-inline %%load-word (array address)
66 (declare (type (simple-array (unsigned-byte 8) (*)) array)
67 (type fixnum address)
68 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
69 (let ((b0 (aref array address)))
70 (declare (type (unsigned-byte 8) b0))
71 (the fixnum
72 (sys:int32-to-integer
73 (sys:int32-logior (sys:int32>> (sys:int32<< b0 24) 16) ;; sign-extend
74 (aref array (the fixnum (1+ address))))))))
75
76(defun-inline %%load-unsigned-word (array address)
77 (declare (type (simple-array (unsigned-byte 8) (*)) array)
78 (type fixnum address)
79 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
80 (the fixnum
81 (sys:int32-to-integer
82 (sys:int32-logior (sys:int32<< (aref array address) 8) (aref array (the fixnum (1+ address)))))))
83
84(defun-inline %%store-word (value array address)
85 (declare (type (simple-array (unsigned-byte 8) (*)) array)
86 (type fixnum address)
87 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
88 (let ((int (sys:integer-to-int32 value)))
89 (declare (type sys:int32 int))
90 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 8))))
91 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer int)))))
92
93;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94
95(defun-inline %%store-tagged (value tag array address)
96 (declare (type (simple-array (unsigned-byte 8) (*)) array)
97 (type fixnum value address tag)
98 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
99 (let ((int (sys:integer-to-int32 value)))
100 (declare (type sys:int32 int))
101 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 21))))
102 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 13))))
103 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 5))))
104 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer
105 (sys:int32-logior (sys:integer-to-int32 tag)
106 (sys:int32<< int 3)))))))
107
108(defun-inline %%load-tagged (array address)
109 (declare (type (simple-array (unsigned-byte 8) (*)) array)
110 (type fixnum address)
111 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
112 (let ((b3 (aref array (the fixnum (+ address 3)))))
113 (declare (type (unsigned-byte 8) b3))
114 (values
115 (the fixnum
116 (sys:int32-to-integer
117 (sys:int32-logior
118 (sys:int32-logior (sys:int32<< (aref array (the fixnum address)) 21)
119 (sys:int32<< (aref array (the fixnum (+ address 1))) 13))
120 (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 5)
121 (sys:int32>> b3 3)))))
122 (pointer-tag b3))))
123
124(defun-inline %%load-pointer (array address)
125 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
126 (multiple-value-bind (value tag) (%%load-tagged array address)
127 (declare (type fixnum value tag))
128 (case tag
129 (#.$t_pos_fixnum (values value t))
130 (#.$t_neg_fixnum (values (the fixnum (+ most-negative-fixnum value)) t))
131 (#.$t_char (values (code-char value) t))
132 (#.$t_imm (values (ecase value
133 (#.$undefined-imm (%unbound-marker))) t))
134 (t (%%load-unsigned-long array address)))))
135
136(defun-inline %%store-pointer (value array address &optional imm?)
137 (cond ((not imm?) (%%store-long value array address))
138 ((fixnump value) (if (>= (the fixnum value) 0)
139 (%%store-tagged value $t_pos_fixnum array address)
140 (%%store-tagged value $t_neg_fixnum array address)))
141 ((characterp value) (%%store-tagged (char-code value) $t_char array address))
142 ;; Do we even need tnis?
143 ((eq value (%unbound-marker)) (%%store-tagged $undefined-imm $t_imm array address))
144 (t (error "~s is an unknown immediate type" value))))
145
146(defun-inline %%load-low-24-bits (array address)
147 (declare (type (simple-array (unsigned-byte 8) (*)) array)
148 (type fixnum address)
149 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
150 (sys:int32-to-integer
151 (sys:int32-logior
152 (sys:int32<< (aref array (the fixnum (+ address 1))) 16)
153 (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 8)
154 (aref array (the fixnum (+ address 3)))))))
155
156(defun-inline %%store-low-24-bits (value array address)
157 (declare (type (simple-array (unsigned-byte 8) (*)) array)
158 (type fixnum address)
159 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
160 (let ((int (sys:integer-to-int32 value)))
161 (declare (type sys:int32 int))
162 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16))))
163 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8))))
164 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int)))))
165
166
167(defparameter *unknown-float* (make-array 1 :element-type 'double-float :initial-element 7.7d70))
168
169(defun make-a-float ()
170 (declare (optimize (safety 0) (speed 3) #+LispWorks (float 0)))
171 ;; This has to box the float, so we get a new float object.
172 (aref (the (simple-array double-float (*)) *unknown-float*) 0))
173
174(defun read-double-float (disk-cache address)
175 (declare (optimize (speed 3) (safety 0) (debug 0)))
176 (let ((float (make-a-float)))
177 (load-bytes-as-byte-vector disk-cache address 8 float $float-read-offset)
178 float))
179
180(defun (setf read-double-float) (value disk-cache address)
181 (declare (optimize (speed 3) (safety 0) (debug 0)))
182 (store-bytes-as-byte-vector value disk-cache address 8 $float-read-offset)
183 value)
184
185(defun store-bytes-from-iarray (array disk-cache address num-bytes)
186 ;; Array is a non-displaced array of immediate data. I won't even begin to guess at the
187 ;; internal format.
188 (let* ((num-elts (array-total-size array))
189 (ivector (make-array num-elts :element-type (array-element-type array))))
190 (loop for i from 0 below num-elts
191 do (setf (aref ivector i) (row-major-aref array i)))
192 (store-bytes-from-ivector ivector disk-cache address num-bytes)
193 array))
Note: See TracBrowser for help on using the repository browser.