Changeset 6
- Timestamp:
- Sep 28, 2007, 7:04:51 PM (13 years ago)
- Location:
- lw-branch
- Files:
-
- 3 added
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
lw-branch/block-io-mcl.lisp
r2 r6 63 63 (in-package :ccl) 64 64 65 ;; N.B. there is another of this in disk-page-hash.lisp!!! - gone now66 ; Assume fixnum addresses.67 ; Comment out this form to compile Wood for files larger than 256 megs.68 (eval-when (:compile-toplevel :execute :load-toplevel)69 (pushnew :wood-fixnum-addresses *features*))70 71 72 65 (export '(stream-read-bytes stream-write-bytes set-minimum-file-length)) 73 66 … … 307 300 308 301 ) ; end of eval-when 309 310 (declaim (inline byte-array-p ensure-byte-array))311 312 #-ppc-target313 (defun byte-array-p (array)314 (and (uvectorp array)315 (let ((subtype (%vect-subtype array)))316 (or (eql subtype $v_sstr)317 (eql subtype $v_ubytev)318 (eql subtype $v_sbytev)))))319 320 #+ppc-target321 (defun byte-array-p (array)322 (let ((typecode (extract-typecode array)))323 (or (eql typecode ppc::subtag-simple-base-string)324 (eql typecode ppc::subtag-s8-vector)325 (eql typecode ppc::subtag-u8-vector))))326 327 (defun ensure-byte-array (array)328 (unless (byte-array-p array)329 (error "~s is not a byte array" array)))330 302 331 303 ; Read length bytes into array at offset from stream at address. -
lw-branch/btrees.lisp
r3 r6 211 211 (simple-string (make-string len :element-type 'base-character))) 212 212 (declare (dynamic-extent simple-string)) 213 (multiple-value-bind (str offset) ( ccl::array-data-and-offset string)213 (multiple-value-bind (str offset) (array-data-and-offset string) 214 214 (wood::%load-string str offset len simple-string)) 215 215 (funcall thunk simple-string)))) … … 358 358 (with-databases-locked 359 359 (with-simple-string (key-string key-string) 360 (if (> (length key-string) 127) 361 (error "Keys longer than 127 bytes not supported yet.")) 360 (when (> (length key-string) 127) 361 #-gz(error "Keys longer than 127 bytes not supported yet.") 362 #+gz(warn "Keys longer than 127 bytes not supported yet.") 363 #+gz (setq key-string (subseq key-string 0 127))) 362 364 (multiple-value-bind (node offset eq) 363 365 (btree-find-leaf-node disk-cache btree key-string) … … 674 676 |# 675 677 678 #+GZ 679 (defun check-used-counts (where disk-cache node) 680 (let* ((used (read-unsigned-word disk-cache (+ node $btree_used))) 681 (count (read-unsigned-word disk-cache (+ node $btree_count))) 682 (bytes (loop for n = 0 then (+ n (normalize-size (+ 5 len) 4)) 683 for i from 0 below count 684 as len = (read-8-bits disk-cache (+ node $btree_data n 4)) 685 finally return n))) 686 ;(FORMAT T "~&CHECK-USED-COUNTS@~s node ~s: [count]=~s, [used]=~s, bytes ~s" 687 ; where node count used bytes) 688 where 689 (assert (<= bytes used)))) 690 691 692 676 693 ; New binary search code: Moon's idea. 677 694 (defun %btree-search-node (disk-cache node key-string case-sensitive?) … … 680 697 (type (simple-array (unsigned-byte 8) (*)) vec)) 681 698 (accessing-byte-array (vec) 699 682 700 (let* ((count (load.uw (+ $btree_count offset))) 683 701 (min 0) ; inclusive lower bound … … 739 757 (return (if (eql i2 end2) 0 -1))) 740 758 (when (>= i2 end2) (return 1)) 741 (let ((c1 ( ccl::%char-code (char-upcase (ccl::%code-char (aref s1 i1)))))742 (c2 ( ccl::%char-code (char-upcase (ccl::%code-char (aref s2 i2))))))759 (let ((c1 (%char-code (char-upcase (%code-char (aref s1 i1))))) 760 (c2 (%char-code (char-upcase (%code-char (aref s2 i2)))))) 743 761 (declare (fixnum c1 c2)) 744 762 (if (<= c1 c2) … … 1286 1304 (defun %shift-node-right (disk-cache btree node free used leaf-p 1287 1305 offset key-string value value-imm? key-length size) 1288 (declare (fixnum free used offset key-length))1306 (declare (fixnum free used)) 1289 1307 ;(return-from %shift-node-right nil) ; not yet debugged. 1290 1308 (when (and leaf-p (not (%btree-root-node-p disk-cache node))) -
lw-branch/disk-cache-accessors.lisp
r3 r6 6 6 ;; low-level accessors for disk-cache's 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 17 18 ;; 18 19 20 (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 (warn "This file must be compiled, it probably won't work evaluated.")) 24 19 25 ;;;;;;;;;;;;;;;;;;;;;;;;;; 20 26 ;; 21 27 ;; Modification History 22 28 ;; 29 ;; 02/01/06 gz LispWorks port 23 30 ;; ------------- 0.961 24 31 ;; 09/19/96 bill The PPC version of %%load-pointer handles short floats now via %%load-short-float … … 52 59 ;; 53 60 54 (in-package : ccl) ; So LAP works easily55 56 (export '( wood::read-long wood::read-unsigned-long57 wood::read-string wood::read-pointer58 wood::read-low-24-bits wood::read-8-bits59 wood::fill-long wood::fill-word wood::fill-byte)60 'wood) 61 61 (in-package :wood) 62 63 (export '(read-long read-unsigned-long 64 read-string read-pointer 65 read-low-24-bits read-8-bits 66 fill-long fill-word fill-byte)) 67 68 #+ccl 62 69 (eval-when (:compile-toplevel :execute) 63 70 #-ppc-target … … 105 112 ) ; end of #+ppc-target progn 106 113 107 (defun wood::read-long (disk-cache address) 108 (wood::with-databases-locked 114 #+LispWorks 115 (progn 116 117 (defun-inline %%load-long (byte-array address) 118 (declare (type (simple-array (unsigned-byte 8) (*)) byte-array) 119 (type fixnum address) 120 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 121 (sys:int32-to-integer 122 (sys:int32-logior 123 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum address)) 24) 124 (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16)) 125 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8) 126 (aref byte-array (the fixnum (+ address 3))))))) 127 128 (defun-inline %%load-unsigned-long (byte-array address) 129 (declare (type (simple-array (unsigned-byte 8) (*)) byte-array) 130 (type fixnum address) 131 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 132 (let* ((b0 (aref byte-array address)) 133 (int (sys:int32-to-integer 134 (sys:int32-logior 135 (sys:int32-logior (sys:int32<< b0 24) 136 (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16)) 137 (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8) 138 (aref byte-array (the fixnum (+ address 3)))))))) 139 (declare (type (unsigned-byte 8) b0)) 140 (if (logbitp 7 b0) 141 (logand #xFFFFFFFF int) 142 int))) 143 ) 144 145 (defun read-long (disk-cache address) 146 (with-databases-locked 109 147 (multiple-value-bind (array index count) 110 ( wood::get-disk-page disk-cache address)148 (get-disk-page disk-cache address) 111 149 (declare (fixnum index count)) 112 150 (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 113 151 (error "Address odd or past eof: ~s" address)) 114 # -ppc-target115 ( lap-inline ()152 #+ccl-68k-target 153 (ccl::lap-inline () 116 154 (:variable array index) 117 ( move.l (varg array)atemp0)118 ( move.l (varg index)da)119 ( getintda)120 ( move.l (atemp0 da.l $v_data)arg_z)121 ( jsr_subprim$sp-mklong))122 # +ppc-target155 (ccl::move.l (ccl::varg array) ccl::atemp0) 156 (ccl::move.l (ccl::varg index) ccl::da) 157 (ccl::getint ccl::da) 158 (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 159 (ccl::jsr_subprim ccl::$sp-mklong)) 160 #-ccl-68k-target 123 161 (%%load-long array index)))) 124 162 … … 132 170 (error "Attempt to access outside of buffer bounds"))))) 133 171 134 (defun wood::%load-long (array address)172 (defun %load-long (array address) 135 173 (ensure-byte-array array) 136 174 (unless (fixnump address) … … 140 178 (unless (eql 0 (the fixnum (logand 1 address))) 141 179 (error "Odd address: ~s" address)) 142 # -ppc-target143 ( lap-inline ()180 #+ccl-68k-target 181 (ccl::lap-inline () 144 182 (:variable array address immediate?) 145 ( move.l (varg array)atemp0)146 ( move.l (varg address)da)147 ( getintda)148 ( move.l (atemp0 da.l $v_data)arg_z)149 ( jsr_subprim$sp-mklong))150 # +ppc-target183 (ccl::move.l (ccl::varg array) ccl::atemp0) 184 (ccl::move.l (ccl::varg address) ccl::da) 185 (ccl::getint ccl::da) 186 (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 187 (ccl::jsr_subprim ccl::$sp-mklong)) 188 #-ccl-68k-target 151 189 (%%load-long array address))) 152 190 153 (defun wood::read-unsigned-long (disk-cache address)154 (w ood::with-databases-locked191 (defun read-unsigned-long (disk-cache address) 192 (with-databases-locked 155 193 (multiple-value-bind (array index count) 156 ( wood::get-disk-page disk-cache address)194 (get-disk-page disk-cache address) 157 195 (declare (fixnum index count)) 158 196 (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 159 197 (error "Address odd or past eof: ~s" address)) 160 # -ppc-target161 ( lap-inline ()198 #+ccl-68k-target 199 (ccl::lap-inline () 162 200 (:variable array index) 163 ( move.l (varg array)atemp0)164 ( move.l (varg index)da)165 ( getintda)166 ( move.l (atemp0 da.l $v_data)arg_z)167 ( jsr_subprim$sp-mkulong))168 # +ppc-target201 (ccl::move.l (ccl::varg array) ccl::atemp0) 202 (ccl::move.l (ccl::varg index) ccl::da) 203 (ccl::getint ccl::da) 204 (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 205 (ccl::jsr_subprim ccl::$sp-mkulong)) 206 #-ccl-68k-target 169 207 (%%load-unsigned-long array index)))) 170 208 171 (defun wood::%load-unsigned-long (array address)209 (defun %load-unsigned-long (array address) 172 210 (ensure-byte-array array) 173 211 (setq address (require-type address 'fixnum)) … … 176 214 (unless (eql 0 (the fixnum (logand 1 address))) 177 215 (error "Odd address: ~s" address)) 178 # -ppc-target179 ( lap-inline ()216 #+ccl-68k-target 217 (ccl::lap-inline () 180 218 (:variable array address) 181 ( move.l (varg array)atemp0)182 ( move.l (varg address)da)183 ( getintda)184 ( move.l (atemp0 da.l $v_data)arg_z)185 ( jsr_subprim$sp-mkulong))186 # +ppc-target219 (ccl::move.l (ccl::varg array) ccl::atemp0) 220 (ccl::move.l (ccl::varg address) ccl::da) 221 (ccl::getint ccl::da) 222 (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 223 (ccl::jsr_subprim ccl::$sp-mkulong)) 224 #-ccl-68k-target 187 225 (%%load-unsigned-long array address))) 188 226 189 227 #+ppc-target 190 (progn 191 192 (declaim (inline %%store-long)) 193 194 (defun %%store-long (value array address) 228 (defun-inline %%store-long (value array address) 195 229 (declare (type (simple-array (unsigned-byte 16) (*)) array) 196 230 (fixnum address) … … 209 243 value) 210 244 211 ) ; end of #+ppc-target progn 212 213 (defun (setf wood::read-long) (value disk-cache address) 214 (unless (>= (wood::disk-cache-size disk-cache) 245 #+LispWorks 246 (defun %%store-long (value array address) 247 (declare (type (simple-array (unsigned-byte 8) (*)) array) 248 (type fixnum address) 249 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 250 (let ((int (sys:integer-to-int32 value))) 251 (declare (type sys:int32 int)) 252 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 24)))) 253 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16)))) 254 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 255 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int))))) 256 257 (defun (setf read-long) (value disk-cache address) 258 (unless (>= (disk-cache-size disk-cache) 215 259 (+ address 4)) 216 ( wood::extend-disk-cache disk-cache (+ address 4)))217 (w ood::with-databases-locked260 (extend-disk-cache disk-cache (+ address 4))) 261 (with-databases-locked 218 262 (multiple-value-bind (array index count) 219 (wood::get-disk-page disk-cache address t)263 (get-disk-page disk-cache address t) 220 264 (declare (fixnum index count)) 221 265 (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 222 266 (error "Address odd or past eof: ~s" address)) 223 #-ppc-target224 (lap-inline ()267 #+ccl-68k-target 268 (ccl::lap-inline () 225 269 (:variable array index value) 226 ( move.l (varg value)arg_z)227 ( jsr_subprim$sp-getxlong)228 ( move.l (varg array)atemp0)229 ( move.l (varg index)da)230 ( getintda)231 ( move.l acc (atemp0 da.l$v_data)))232 #+ppc-target233 270 (ccl::move.l (ccl::varg value) ccl::arg_z) 271 (ccl::jsr_subprim ccl::$sp-getxlong) 272 (ccl::move.l (ccl::varg array) ccl::atemp0) 273 (ccl::move.l (ccl::varg index) ccl::da) 274 (ccl::getint ccl::da) 275 (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data))) 276 #-ccl-68k-target 277 (%%store-long value array index))) 234 278 value) 235 279 236 (defsetf wood::read-unsigned-long (disk-cache address) (value)237 `(setf ( wood::read-long ,disk-cache ,address) ,value))238 239 (defun wood::%store-long (value array address)280 (defsetf read-unsigned-long (disk-cache address) (value) 281 `(setf (read-long ,disk-cache ,address) ,value)) 282 283 (defun %store-long (value array address) 240 284 (ensure-byte-array array) 241 285 (setq address (require-type address 'fixnum)) … … 244 288 (unless (eql 0 (the fixnum (logand 1 address))) 245 289 (error "Odd address: ~s" address)) 246 # -ppc-target247 ( lap-inline ()290 #+ccl-68k-target 291 (ccl::lap-inline () 248 292 (:variable array address value) 249 ( move.l (varg value)arg_z)250 ( jsr_subprim$sp-getxlong)251 ( move.l (varg array)atemp0)252 ( move.l (varg address)da)253 ( getintda)254 ( move.l acc (atemp0 da.l$v_data)))255 # +ppc-target293 (ccl::move.l (ccl::varg value) ccl::arg_z) 294 (ccl::jsr_subprim ccl::$sp-getxlong) 295 (ccl::move.l (ccl::varg array) ccl::atemp0) 296 (ccl::move.l (ccl::varg address) ccl::da) 297 (ccl::getint ccl::da) 298 (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data))) 299 #-ccl-68k-target 256 300 (%%store-long value array address)) 257 301 value) 258 302 259 (defun wood::read-word (disk-cache address) 260 (wood::with-databases-locked 303 #+ppc-target 304 (progn 305 306 (defun-inline %%load-word (array index) 307 (locally (declare (type (simple-array (signed-byte 16) (*)) array) 308 (optimize (speed 3) (safety 0))) 309 (setq index (ash index -1)) 310 (aref array index))) 311 312 (defun-inline %%load-unsigned-word (array index) 313 (declare (type (simple-array (unsigned-byte 16) (*)) array) 314 (optimize (speed 3) (safety 0))) 315 (aref array (the fixnum (ash index -1)))) 316 317 (defun-inline %%store-word (value array index) 318 (locally (declare (type (simple-array (unsigned-byte 16) (*)) array) 319 (type fixnum index) 320 (optimize (speed 3) (safety 0))) 321 (setq index (ash index -1)) 322 (setf (aref array index) value))) 323 324 ) 325 326 327 #+LispWorks 328 (progn 329 (defun-inline %%load-word (array address) 330 (declare (type (simple-array (unsigned-byte 8) (*)) array) 331 (type fixnum address) 332 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 333 (let ((b0 (aref array address))) 334 (declare (type (unsigned-byte 8) b0)) 335 (the fixnum 336 (sys:int32-to-integer 337 (sys:int32-logior (sys:int32>> (sys:int32<< b0 24) 16) ;; sign-extend 338 (aref array (the fixnum (1+ address)))))))) 339 340 (defun-inline %%load-unsigned-word (array address) 341 (declare (type (simple-array (unsigned-byte 8) (*)) array) 342 (type fixnum address) 343 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 344 (the fixnum 345 (sys:int32-to-integer 346 (sys:int32-logior (sys:int32<< (aref array address) 8) (aref array (the fixnum (1+ address))))))) 347 348 (defun-inline %%store-word (value array address) 349 (declare (type (simple-array (unsigned-byte 8) (*)) array) 350 (type fixnum address) 351 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 352 (let ((int (sys:integer-to-int32 value))) 353 (declare (type sys:int32 int)) 354 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 355 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer int))))) 356 ) 357 358 (defun read-word (disk-cache address) 359 (with-databases-locked 261 360 (multiple-value-bind (array index count) 262 ( wood::get-disk-page disk-cache address)361 (get-disk-page disk-cache address) 263 362 (declare (fixnum index count)) 264 363 (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 265 364 (error "Address odd or past eof: ~s" address)) 266 # -ppc-target267 ( lap-inline ()365 #+ccl-68k-target 366 (ccl::lap-inline () 268 367 (:variable array index) 269 (move.l (varg array) atemp0) 270 (move.l (varg index) da) 271 (getint da) 272 (move.w (atemp0 da.l $v_data) acc) 273 (ext.l acc) 274 (mkint acc)) 275 #+ppc-target 276 (locally (declare (type (simple-array (signed-byte 16) (*)) array) 277 (optimize (speed 3) (safety 0))) 278 (setq index (ash index -1)) 279 (aref array index))))) 280 281 (defun wood::%load-word (array address) 368 (ccl::move.l (ccl::varg array) ccl::atemp0) 369 (ccl::move.l (ccl::varg index) ccl::da) 370 (ccl::getint ccl::da) 371 (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 372 (ccl::ext.l ccl::acc) 373 (ccl::mkint ccl::acc)) 374 #-ccl-68k-target 375 (%%load-word array index)))) 376 377 (defun %load-word (array address) 282 378 (ensure-byte-array array) 283 379 (setq address (require-type address 'fixnum)) … … 286 382 (unless (eql 0 (the fixnum (logand 1 address))) 287 383 (error "Odd address: ~s" address)) 288 # -ppc-target289 ( lap-inline ()384 #+ccl-68k-target 385 (ccl::lap-inline () 290 386 (:variable array address) 291 (move.l (varg array) atemp0) 292 (move.l (varg address) da) 293 (getint da) 294 (move.w (atemp0 da.l $v_data) acc) 295 (ext.l acc) 296 (mkint acc)) 297 #+ppc-target 298 (locally (declare (type (simple-array (signed-byte 16) (*)) array) 299 (optimize (speed 3) (safety 0))) 300 (setq address (ash address -1)) 301 (aref array address)))) 302 303 (defun wood::read-unsigned-word (disk-cache address) 304 (wood::with-databases-locked 387 (ccl::move.l (ccl::varg array) ccl::atemp0) 388 (ccl::move.l (ccl::varg address) ccl::da) 389 (ccl::getint ccl::da) 390 (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 391 (ccl::ext.l ccl::acc) 392 (ccl::mkint ccl::acc)) 393 #-ccl-68k-target 394 (%%load-word array address))) 395 396 (defun read-unsigned-word (disk-cache address) 397 (with-databases-locked 305 398 (multiple-value-bind (array index count) 306 ( wood::get-disk-page disk-cache address)399 (get-disk-page disk-cache address) 307 400 (declare (fixnum index count)) 308 401 (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 309 402 (error "Address odd or past eof: ~s" address)) 310 # -ppc-target311 ( lap-inline ()403 #+ccl-68k-target 404 (ccl::lap-inline () 312 405 (:variable array index) 313 (move.l (varg array) atemp0) 314 (move.l (varg index) da) 315 (getint da) 316 (move.l ($ 0) acc) 317 (move.w (atemp0 da.l $v_data) acc) 318 (mkint acc)) 319 #+ppc-target 320 (locally (declare (type (simple-array (unsigned-byte 16) (*)) array) 321 (optimize (speed 3) (safety 0))) 322 (setq index (ash index -1)) 323 (aref array index))))) 324 325 (defun wood::%load-unsigned-word (array address) 406 (ccl::move.l (ccl::varg array) ccl::atemp0) 407 (ccl::move.l (ccl::varg index) ccl::da) 408 (ccl::getint ccl::da) 409 (ccl::move.l (ccl::$ 0) ccl::acc) 410 (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 411 (ccl::mkint ccl::acc)) 412 #-ccl-68k-target 413 (%%load-unsigned-word array index)))) 414 415 (defun %load-unsigned-word (array address) 326 416 (ensure-byte-array array) 327 417 (setq address (require-type address 'fixnum)) … … 330 420 (unless (eql 0 (the fixnum (logand 1 address))) 331 421 (error "Odd address: ~s" address)) 332 # -ppc-target333 ( lap-inline ()422 #+ccl-68k-target 423 (ccl::lap-inline () 334 424 (:variable array address) 335 (move.l (varg array) atemp0) 336 (move.l (varg address) da) 337 (getint da) 338 (move.l ($ 0) acc) 339 (move.w (atemp0 da.l $v_data) acc) 340 (mkint acc)) 341 #+ppc-target 342 (locally (declare (type (simple-array (unsigned-byte 16) (*)) array) 343 (optimize (speed 3) (safety 0))) 344 (setq address (ash address -1)) 345 (aref array address)))) 346 347 (defun (setf wood::read-word) (value disk-cache address) 425 (ccl::move.l (ccl::varg array) ccl::atemp0) 426 (ccl::move.l (ccl::varg address) ccl::da) 427 (ccl::getint ccl::da) 428 (ccl::move.l (ccl::$ 0) ccl::acc) 429 (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 430 (ccl::mkint ccl::acc)) 431 #-ccl-68k-target 432 (%%load-unsigned-word array address))) 433 434 (defun (setf read-word) (value disk-cache address) 348 435 (setq value (require-type value 'fixnum)) 349 (unless (>= ( wood::disk-cache-size disk-cache)436 (unless (>= (disk-cache-size disk-cache) 350 437 (+ address 4)) 351 ( wood::extend-disk-cache disk-cache (+ address 4)))352 (w ood::with-databases-locked438 (extend-disk-cache disk-cache (+ address 4))) 439 (with-databases-locked 353 440 (multiple-value-bind (array index count) 354 ( wood::get-disk-page disk-cache address t)441 (get-disk-page disk-cache address t) 355 442 (declare (fixnum index count)) 356 443 (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 357 444 (error "Odd address: ~s" address)) 358 # -ppc-target359 ( lap-inline ()445 #+ccl-68k-target 446 (ccl::lap-inline () 360 447 (:variable array index value) 361 (move.l (varg value) acc) 362 (getint acc) 363 (move.l (varg array) atemp0) 364 (move.l (varg index) da) 365 (getint da) 366 (move.w acc (atemp0 da.l $v_data)) 367 (mkint acc)) 368 #+ppc-target 369 (locally (declare (type (simple-array (unsigned-byte 16) (*)) array) 370 (optimize (speed 3) (safety 0))) 371 (setq index (ash index -1)) 372 (setf (aref array index) value))))) 373 374 (defsetf wood::read-unsigned-word (disk-cache address) (value) 375 `(setf (wood::read-word ,disk-cache ,address) ,value)) 376 377 (defun wood::%store-word (value array address) 448 (ccl::move.l (ccl::varg value) ccl::acc) 449 (ccl::getint ccl::acc) 450 (ccl::move.l (ccl::varg array) ccl::atemp0) 451 (ccl::move.l (ccl::varg index) ccl::da) 452 (ccl::getint ccl::da) 453 (ccl::move.w ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)) 454 (ccl::mkint ccl::acc)) 455 #-ccl-68k-target 456 (%%store-word value array index)))) 457 458 (defsetf read-unsigned-word (disk-cache address) (value) 459 `(setf (read-word ,disk-cache ,address) ,value)) 460 461 (defun %store-word (value array address) 378 462 (ensure-byte-array array) 379 463 (setq address (require-type address 'fixnum)) … … 382 466 (unless (eql 0 (the fixnum (logand 1 address))) 383 467 (error "Address not word aligned: ~s" address)) 384 # -ppc-target385 ( lap-inline ()468 #+ccl-68k-target 469 (ccl::lap-inline () 386 470 (:variable value array address) 387 (move.l (varg array) atemp0) 388 (move.l (varg address) da) 389 (getint da) 390 (move.l (varg value) acc) 391 (getint acc) 392 (move.w acc (atemp0 da.l $v_data)) 393 (mkint acc)) 394 #+ppc-target 395 (locally (declare (type (simple-array (unsigned-byte 16) (*)) array) 396 (optimize (speed 3) (safety 0))) 397 (setq address (ash address -1)) 398 (setf (aref array address) value)))) 399 400 401 (declaim (inline wood::%%load-pointer wood::%%store-pointer)) 471 (ccl::move.l (ccl::varg array) ccl::atemp0) 472 (ccl::move.l (ccl::varg address) ccl::da) 473 (ccl::getint ccl::da) 474 (ccl::move.l (ccl::varg value) ccl::acc) 475 (ccl::getint ccl::acc) 476 (ccl::move.w ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)) 477 (ccl::mkint ccl::acc)) 478 #-ccl-68k-target 479 (%%store-word value array address))) 480 481 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 402 482 403 483 ; same as %load-pointer, but does no type checking 404 #-ppc-target 405 (defun wood::%%load-pointer (array address) 484 #+ccl-68k-target 485 (progn 486 487 (defun-inline %%load-pointer (array address) 406 488 (let (immediate?) 407 489 (values 408 ( lap-inline ()490 (ccl::lap-inline () 409 491 (:variable array address immediate?) 410 ( move.l (varg array)atemp0)411 ( move.l (varg address)da)412 ( getintda)413 ( move.l (atemp0 da.l $v_data)arg_z)414 ( if# (ne (dtagp arg_z $t_fixnum $t_imm$t_sfloat))415 ( movereg arg_zacc)416 ( move.l '1 (varg immediate?))417 else#418 ( jsr_subprim$sp-mkulong)))492 (ccl::move.l (ccl::varg array) ccl::atemp0) 493 (ccl::move.l (ccl::varg address) ccl::da) 494 (ccl::getint ccl::da) 495 (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 496 (ccl::if# (ccl::ne (ccl::dtagp ccl::arg_z ccl::$t_fixnum ccl::$t_imm ccl::$t_sfloat)) 497 (ccl::movereg ccl::arg_z ccl::acc) 498 (ccl::move.l '1 (ccl::varg immediate?)) 499 ccl::else# 500 (ccl::jsr_subprim ccl::$sp-mkulong))) 419 501 immediate?))) 420 502 421 503 ; Same as %store-pointer, but doesn't type check 422 #-ppc-target 423 (defun wood::%%store-pointer (value array address &optional immediate?) 424 (lap-inline () 504 (defun-inline %%store-pointer (value array address &optional immediate?) 505 (ccl::lap-inline () 425 506 (:variable array address value immediate?) 426 (move.l (varg value) arg_z) 427 (if# (eq (cmp.l (varg immediate?) nilreg)) 428 (jsr_subprim $sp-getxlong)) 429 (move.l (varg array) atemp0) 430 (move.l (varg address) da) 431 (getint da) 432 (move.l acc (atemp0 da.l $v_data)))) 507 (ccl::move.l (ccl::varg value) ccl::arg_z) 508 (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 509 (ccl::jsr_subprim ccl::$sp-getxlong)) 510 (ccl::move.l (ccl::varg array) ccl::atemp0) 511 (ccl::move.l (ccl::varg address) ccl::da) 512 (ccl::getint ccl::da) 513 (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)))) 514 ) 433 515 434 516 #+ppc-target … … 436 518 437 519 ; Load a Wood fixnum returning a lisp fixnum 438 ( defppclapfunction wood::%%load-fixnum ((array arg_y) (addressarg_z))439 ( unbox-fixnumimm0 address)440 ( la imm0 ppc::misc-data-offsetimm0)441 ( lwzx imm0imm0 array)442 ( srawi imm0imm0 3)443 ( box-fixnum arg_zimm0)444 ( blr))445 446 ( defppclapfunction wood::%%store-fixnum ((value arg_x) (array arg_y) (addressarg_z))447 ( unbox-fixnumimm0 address)448 ( la imm0 ppc::misc-data-offsetimm0)449 ( slwiimm1 value (- 3 ppc::fixnum-shift))450 ( stwx imm1imm0 array)451 ( mr arg_zarg_x)452 ( blr))520 (ccl::defppclapfunction %%load-fixnum ((array ccl::arg_y) (address ccl::arg_z)) 521 (ccl::unbox-fixnum ccl::imm0 address) 522 (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 523 (ccl::lwzx ccl::imm0 ccl::imm0 array) 524 (ccl::srawi ccl::imm0 ccl::imm0 3) 525 (ccl::box-fixnum ccl::arg_z ccl::imm0) 526 (ccl::blr)) 527 528 (ccl::defppclapfunction %%store-fixnum ((value ccl::arg_x) (array ccl::arg_y) (address ccl::arg_z)) 529 (ccl::unbox-fixnum ccl::imm0 address) 530 (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 531 (ccl::slwi ccl::imm1 value (- 3 ppc::fixnum-shift)) 532 (ccl::stwx ccl::imm1 ccl::imm0 array) 533 (ccl::mr ccl::arg_z ccl::arg_x) 534 (ccl::blr)) 453 535 454 536 ; Load a Wood character returning a lisp character 455 ( defppclapfunction wood::%%load-character ((array arg_y) (addressarg_z))456 ( unbox-fixnumimm0 address)457 ( la imm0 ppc::misc-data-offsetimm0)458 ( lwzx imm0imm0 array)459 ( liarg_z ppc::subtag-character)460 ( rlwimi arg_zimm0 0 0 15)461 ( blr))462 463 ( defppclapfunction wood::%%store-character ((value arg_x) (array arg_y) (addressarg_z))464 ( unbox-fixnumimm0 address)465 ( la imm0 ppc::misc-data-offsetimm0)466 ( li imm1$t_imm_char)467 ( rlwimiimm1 value 0 0 15)468 ( stwx imm1imm0 array)469 ( mr arg_zarg_x)470 ( blr))471 472 (defun wood::%%load-pointer (array address)537 (ccl::defppclapfunction %%load-character ((array ccl::arg_y) (address ccl::arg_z)) 538 (ccl::unbox-fixnum ccl::imm0 address) 539 (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 540 (ccl::lwzx ccl::imm0 ccl::imm0 array) 541 (ccl::li ccl::arg_z ppc::subtag-character) 542 (ccl::rlwimi ccl::arg_z ccl::imm0 0 0 15) 543 (ccl::blr)) 544 545 (ccl::defppclapfunction %%store-character ((value ccl::arg_x) (array ccl::arg_y) (address ccl::arg_z)) 546 (ccl::unbox-fixnum ccl::imm0 address) 547 (ccl::la imm0 ppc::misc-data-offset ccl::imm0) 548 (ccl::li ccl::imm1 ccl::$t_imm_char) 549 (ccl::rlwimi ccl::imm1 value 0 0 15) 550 (ccl::stwx ccl::imm1 ccl::imm0 array) 551 (ccl::mr ccl::arg_z ccl::arg_x) 552 (ccl::blr)) 553 554 (defun-inline %%load-pointer (array address) 473 555 (declare (optimize (speed 3) (safety 0)) 474 556 (fixnum address)) … … 480 562 (declare (fixnum tag-byte tag)) 481 563 (case tag 482 (#. wood::$t_fixnum483 (values ( wood::%%load-fixnum array address) t))484 (#. wood::$t_imm564 (#.$t_fixnum 565 (values (%%load-fixnum array address) t)) 566 (#.$t_imm 485 567 (values 486 568 (ecase tag-byte 487 (#. $undefined (%unbound-marker-8))488 (#. $illegal (%illegal-marker))489 (#. $t_imm_char (wood::%%load-character array address)))569 (#.ccl::$undefined (%unbound-marker)) 570 (#.ccl::$illegal (ccl::%illegal-marker)) 571 (#.ccl::$t_imm_char (%%load-character array address))) 490 572 t)) 491 (#. wood::$t_sfloat492 (values ( wood::%%load-short-float array address) t))573 (#.$t_sfloat 574 (values (%%load-short-float array address) t)) 493 575 (t (%%load-unsigned-long array address))))) 494 576 495 (defun wood::%%load-short-float (array address)577 (defun %%load-short-float (array address) 496 578 (declare (fixnum address) 497 579 (type (simple-array (unsigned-byte 8) (*)) array) … … 531 613 res)) 532 614 533 (defun wood::%%store-pointer (value array address &optional imm?)615 (defun-inline %%store-pointer (value array address &optional imm?) 534 616 (cond ((not imm?) 535 617 (%%store-long value array address)) 536 ((fixnump value) ( wood::%%store-fixnum value array address))537 ((characterp value) ( wood::%%store-character value array address))538 ((eq value (%unbound-marker -8))539 (%%store-long $undefined array address))540 ((eq value ( %illegal-marker))541 (%%store-long $illegal array address))618 ((fixnump value) (%%store-fixnum value array address)) 619 ((characterp value) (%%store-character value array address)) 620 ((eq value (%unbound-marker)) 621 (%%store-long ccl::$undefined array address)) 622 ((eq value (ccl::%illegal-marker)) 623 (%%store-long ccl::$illegal array address)) 542 624 (t (error "~s is not a valid immediate" value))) 543 625 value) … … 545 627 ) ; end of #+ppc-target progn 546 628 629 #+LispWorks 630 (progn 631 632 (defun-inline %%store-tagged (value tag array address) 633 (declare (type (simple-array (unsigned-byte 8) (*)) array) 634 (type fixnum value address tag) 635 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 636 (let ((int (sys:integer-to-int32 value))) 637 (declare (type sys:int32 int)) 638 (setf (aref array (the fixnum address)) (the fixnum (sys:int32-to-integer (sys:int32>> int 21)))) 639 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 13)))) 640 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 5)))) 641 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer 642 (sys:int32-logior (sys:integer-to-int32 tag) 643 (sys:int32<< int 3))))))) 644 (defun-inline %%load-tagged (array address) 645 (declare (type (simple-array (unsigned-byte 8) (*)) array) 646 (type fixnum address) 647 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 648 (let ((b3 (aref array (the fixnum (+ address 3))))) 649 (declare (type (unsigned-byte 8) b3)) 650 (values 651 (the fixnum 652 (sys:int32-to-integer 653 (sys:int32-logior 654 (sys:int32-logior (sys:int32<< (aref array (the fixnum address)) 21) 655 (sys:int32<< (aref array (the fixnum (+ address 1))) 13)) 656 (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 5) 657 (sys:int32>> b3 3))))) 658 (pointer-tag b3)))) 659 660 (defun-inline %%load-pointer (array address) 661 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 662 (multiple-value-bind (value tag) (%%load-tagged array address) 663 (declare (type fixnum value tag)) 664 (case tag 665 (#.$t_pos_fixnum (values value t)) 666 (#.$t_neg_fixnum (values (the fixnum (+ most-negative-fixnum value)) t)) 667 (#.$t_char (values (code-char value) t)) 668 (#.$t_imm (values (ecase value 669 (#.$undefined-imm (%unbound-marker))) t)) 670 (t (%%load-unsigned-long array address))))) 671 672 (defun-inline %%store-pointer (value array address &optional imm?) 673 (cond ((not imm?) (%%store-long value array address)) 674 ((fixnump value) (if (>= (the fixnum value) 0) 675 (%%store-tagged value $t_pos_fixnum array address) 676 (%%store-tagged value $t_neg_fixnum array address))) 677 ((characterp value) (%%store-tagged (char-code value) $t_char array address)) 678 ;; Do we even need tnis? 679 ((eq value (%unbound-marker)) (%%store-tagged $undefined-imm $t_imm array address)) 680 (t (error "~s is an unknown immediate type" value)))) 681 682 ) ; end of #+LispWorks progn 683 547 684 ; Avoid consing bignums by not boxing immediate data from the file. 548 685 ; Second value is true if the result was immediate. 549 (defun wood::read-pointer (disk-cache address) 550 (wood::with-databases-locked 686 (defun read-pointer (disk-cache address #+LispWorks &optional #+LispWorks ignore) 687 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 688 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 689 (with-databases-locked 551 690 (multiple-value-bind (array index count) 552 ( wood::get-disk-page disk-cache address)691 (get-disk-page disk-cache address) 553 692 (declare (fixnum index count)) 554 693 (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 555 694 (error "Address odd or past eof: ~s" address)) 556 ( wood::%%load-pointer array index))))695 (%%load-pointer array index)))) 557 696 558 697 ; load directly from a byte array. 559 (defun wood::%load-pointer (array address)698 (defun %load-pointer (array address) 560 699 (ensure-byte-array array) 561 700 (setq address (require-type address 'fixnum)) … … 564 703 (unless (eql 0 (the fixnum (logand 1 address))) 565 704 (error "Odd address: ~s" address)) 566 ( wood::%%load-pointer array address)))567 568 (defun (setf wood::read-pointer) (value disk-cache address &optional immediate?)569 (unless (>= ( wood::disk-cache-size disk-cache)705 (%%load-pointer array address))) 706 707 (defun (setf read-pointer) (value disk-cache address &optional immediate?) 708 (unless (>= (disk-cache-size disk-cache) 570 709 (+ address 4)) 571 ( wood::extend-disk-cache disk-cache (+ address 4)))572 (w ood::with-databases-locked710 (extend-disk-cache disk-cache (+ address 4))) 711 (with-databases-locked 573 712 (multiple-value-bind (array index count) 574 ( wood::get-disk-page disk-cache address t)713 (get-disk-page disk-cache address t) 575 714 (declare (fixnum index count)) 576 715 (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 577 716 (error "Address odd or past eof: ~s" address)) 578 ( wood::%%store-pointer value array index immediate?)))717 (%%store-pointer value array index immediate?))) 579 718 value) 580 719 581 (defun wood::%store-pointer (value array address &optional immediate?)720 (defun %store-pointer (value array address &optional immediate?) 582 721 (ensure-byte-array array) 583 722 (setq address (require-type address 'fixnum)) … … 586 725 (unless (eql 0 (the fixnum (logand 1 address))) 587 726 (error "Odd address: ~s" address)) 588 ( wood::%%store-pointer value array address immediate?))727 (%%store-pointer value array address immediate?)) 589 728 value) 590 729 591 (declaim (inline wood::%%load-low-24-bits %%store-low-24-bits)) 592 593 (defun wood::%%load-low-24-bits (array index) 730 #+ccl (progn 731 (declaim (inline %%load-low-24-bits %%store-low-24-bits)) 732 733 (defun %%load-low-24-bits (array index) 594 734 (declare (optimize (speed 3) (safety 0)) 595 735 (fixnum index)) … … 605 745 (+ (the fixnum (ash high-word 16)) low-word)))) 606 746 607 (defun wood::%%store-low-24-bits (value array index)747 (defun %%store-low-24-bits (value array index) 608 748 (declare (optimize (speed 3) (safety 0)) 609 749 (fixnum value index)) … … 617 757 (setf (aref array (the fixnum (1+ index))) high-word))) 618 758 value) 619 620 (defun wood::read-low-24-bits (disk-cache address) 621 (wood::with-databases-locked 759 ) ;#+ccl 760 761 #+LispWorks (progn 762 (defun-inline %%load-low-24-bits (array address) 763 (declare (type (simple-array (unsigned-byte 8) (*)) array) 764 (type fixnum address) 765 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 766 (sys:int32-to-integer 767 (sys:int32-logior 768 (sys:int32<< (aref array (the fixnum (+ address 1))) 16) 769 (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 8) 770 (aref array (the fixnum (+ address 3))))))) 771 772 (defun-inline %%store-low-24-bits (value array address) 773 (declare (type (simple-array (unsigned-byte 8) (*)) array) 774 (type fixnum address) 775 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 776 (let ((int (sys:integer-to-int32 value))) 777 (declare (type sys:int32 int)) 778 (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16)))) 779 (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 780 (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int))))) 781 ) ;#+LispWorks 782 783 (defun read-low-24-bits (disk-cache address) 784 (with-databases-locked 622 785 (multiple-value-bind (array index count) 623 ( wood::get-disk-page disk-cache address)786 (get-disk-page disk-cache address) 624 787 (declare (fixnum index count)) 625 788 (unless (>= count 4) 626 789 (error "Address past eof or not longword aligned: ~s" address)) 627 ( wood::%%load-low-24-bits array index))))628 629 (defun (setf wood::read-low-24-bits) (value disk-cache address)790 (%%load-low-24-bits array index)))) 791 792 (defun (setf read-low-24-bits) (value disk-cache address) 630 793 (unless (fixnump value) 631 794 (setq value (require-type value 'fixnum))) 632 (unless (>= ( wood::disk-cache-size disk-cache)795 (unless (>= (disk-cache-size disk-cache) 633 796 (+ address 4)) 634 ( wood::extend-disk-cache disk-cache (+ address 4)))635 (w ood::with-databases-locked797 (extend-disk-cache disk-cache (+ address 4))) 798 (with-databases-locked 636 799 (multiple-value-bind (array index count) 637 ( wood::get-disk-page disk-cache address t)800 (get-disk-page disk-cache address t) 638 801 (declare (fixnum index count)) 639 802 (unless (>= count 4) 640 803 (error "Address not longword aligned: ~s" address)) 641 ( wood::%%store-low-24-bits value array index)))804 (%%store-low-24-bits value array index))) 642 805 value) 643 806 644 807 ; Read an unsigned byte. Can't call it read-byte as Common Lisp 645 808 ; already exports that symbol 646 (defun wood::read-8-bits (disk-cache address)647 (w ood::with-databases-locked809 (defun read-8-bits (disk-cache address) 810 (with-databases-locked 648 811 (multiple-value-bind (array index count) 649 ( wood::get-disk-page disk-cache address)812 (get-disk-page disk-cache address) 650 813 (declare (fixnum index count) 651 814 (type (simple-array (unsigned-byte 8) (*)) array) … … 655 818 (aref array index)))) 656 819 657 (defun wood::read-8-bits-signed (disk-cache address)658 (w ood::with-databases-locked820 (defun read-8-bits-signed (disk-cache address) 821 (with-databases-locked 659 822 (multiple-value-bind (array index count) 660 ( wood::get-disk-page disk-cache address)823 (get-disk-page disk-cache address) 661 824 (declare (fixnum index count) 662 (type (simple-array (signed-byte 8) (*)) array) 825 (type (simple-array (signed-byte 8) (*)) array) ;lie 663 826 (optimize (speed 3) (safety 0))) 664 827 (unless (>= count 1) … … 666 829 (aref array index)))) 667 830 668 (defun wood::%load-8-bits (array address)831 (defun %load-8-bits (array address) 669 832 (ensure-byte-array array) 670 833 (setq address (require-type address 'fixnum)) … … 675 838 (aref array address))) 676 839 677 (defun (setf wood::read-8-bits) (value disk-cache address)678 (unless (>= ( wood::disk-cache-size disk-cache)840 (defun (setf read-8-bits) (value disk-cache address) 841 (unless (>= (disk-cache-size disk-cache) 679 842 (+ address 4)) 680 ( wood::extend-disk-cache disk-cache (+ address 4)))681 (w ood::with-databases-locked843 (extend-disk-cache disk-cache (+ address 4))) 844 (with-databases-locked 682 845 (multiple-value-bind (array index count) 683 ( wood::get-disk-page disk-cache address t)846 (get-disk-page disk-cache address t) 684 847 (declare (fixnum index count) 685 848 (type (simple-array (unsigned-byte 8) (*)) array) … … 689 852 (setf (aref array index) value)))) 690 853 691 (defsetf wood::read-8-bits-signed (disk-cache address) (value)692 `(setf ( wood::read-8-bits ,disk-cache ,address) ,value))693 694 (defun wood::%store-8-bits (value array address)854 (defsetf read-8-bits-signed (disk-cache address) (value) 855 `(setf (read-8-bits ,disk-cache ,address) ,value)) 856 857 (defun %store-8-bits (value array address) 695 858 (ensure-byte-array array) 696 859 (setq address (require-type address 'fixnum)) … … 702 865 703 866 ; These will get less ugly when we can stack cons float vectors 704 # -ppc-target705 (defun wood::read-double-float (disk-cache address)867 #+ccl-68k-target (progn 868 (defun read-double-float (disk-cache address) 706 869 (let ((vector (make-array 2 :element-type '(signed-byte 32)))) 707 870 (declare (dynamic-extent vector)) 708 ( wood::load-byte-array disk-cache address 8 vector 0 t)871 (load-bytes-to-ivector disk-cache address 8 vector) 709 872 (ccl::%typed-uvref ccl::$v_floatv vector 0))) 710 873 711 #+ppc-target 712 (defun wood::read-double-float (disk-cache address) 713 (let ((float (%copy-float 0.0))) 714 (wood::load-byte-array disk-cache address 8 float 4 t) 715 float)) 716 717 #-ppc-target 718 (defun (setf wood::read-double-float) (value disk-cache address) 874 (defun (setf read-double-float) (value disk-cache address) 719 875 (let ((vector (make-array 2 :element-type '(signed-byte 32)))) 720 876 (declare (dynamic-extent vector)) 721 877 (ccl::%typed-uvset ccl::$v_floatv vector 0 value) 722 ( wood::store-byte-array vector disk-cache address 8 0 t))878 (store-bytes-as-byte-vector vector disk-cache address 8 0)) 723 879 value) 724 725 #+ppc-target 726 (defun (setf wood::read-double-float) (value disk-cache address) 880 ) ; #+ccl-68k-target 881 882 #+ppc-target (progn 883 (defun (setf read-double-float) (value disk-cache address) 727 884 (unless (typep value 'double-float) 728 885 (setq value (require-type value 'double-float))) 729 ( wood::store-byte-array value disk-cache address 8 4 t)886 (store-bytes-as-byte-vector value disk-cache address 8 4) 730 887 value) 731 888 732 (defun wood::read-string (disk-cache address length &optional string) 889 (defun read-double-float (disk-cache address) 890 (let ((float (ccl::%copy-float 0.0))) 891 (load-bytes-as-byte-vector disk-cache address 8 float 4) ;; lie 892 float)) 893 ) ; #+ppc-target 894 895 #+LispWorks 896 (progn 897 898 (defparameter *unknown-float* (make-array 1 :element-type 'double-float :initial-element 7.7d70)) 899 900 (defun make-a-float () 901 (declare (optimize (safety 0) (speed 3) #+LispWorks (float 0))) 902 ;; This has to box the float, so we get a new float object. 903 (aref (the (simple-array double-float (*)) *unknown-float*) 0)) 904 905 (defun read-double-float (disk-cache address) 906 (declare (optimize (speed 3) (safety 0) (debug 0))) 907 (let ((float (make-a-float))) 908 (load-bytes-as-byte-vector disk-cache address 8 float $float-read-offset) 909 float)) 910 911 (defun (setf read-double-float) (value disk-cache address) 912 (declare (optimize (speed 3) (safety 0) (debug 0))) 913 (store-bytes-as-byte-vector value disk-cache address 8 $float-read-offset) 914 value) 915 ) ; #+LispWorks 916 917 (defun read-string (disk-cache address length &optional string) 733 918 (setq length (require-type length 'fixnum)) 734 919 (locally (declare (fixnum length)) 735 (when (> (+ address length) ( wood::disk-cache-size disk-cache))920 (when (> (+ address length) (disk-cache-size disk-cache)) 736 921 (error "Attempt to read past EOF")) 737 922 (let ((offset 0) … … 755 940 (setq string (make-string length :element-type 'base-character))))) 756 941 (loop 757 (w ood::with-databases-locked942 (with-databases-locked 758 943 (multiple-value-bind (array index count) 759 ( wood::get-disk-page disk-cache address)944 (get-disk-page disk-cache address) 760 945 (declare (fixnum count index)) 761 # -ppc-target762 ( lap-inline ()946 #+ccl-68k-target 947 (ccl::lap-inline () 763 948 (:variable array index count length inner-string offset) 764 ( move.l (varg array)atemp0)765 ( move.l (varg index)da)766 ( getintda)767 ( lea (atemp0 da.l $v_data)atemp0)768 ( move.l (varg inner-string)atemp1)769 ( move.l (varg offset)da)770 ( getintda)771 ( lea (atemp1 da.l $v_data)atemp1)772 ( move.l (varg length)da)773 ( if# (gt (cmp.l (varg count)da))774 ( move.l (varg count)da))775 ( getintda)776 ( dbfloop.lda777 ( move.b atemp0@+atemp1@+)))778 # +ppc-target779 ( %copy-ivector-to-ivector949 (ccl::move.l (ccl::varg array) ccl::atemp0) 950 (ccl::move.l (ccl::varg index) ccl::da) 951 (ccl::getint ccl::da) 952 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 953 (ccl::move.l (ccl::varg inner-string) ccl::atemp1) 954 (ccl::move.l (ccl::varg offset) ccl::da) 955 (ccl::getint ccl::da) 956 (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 957 (ccl::move.l (ccl::varg length) ccl::da) 958 (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 959 (ccl::move.l (ccl::varg count) ccl::da)) 960 (ccl::getint ccl::da) 961 (ccl::dbfloop.l ccl::da 962 (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))) 963 #-ccl-68k-target 964 (copy-as-byte-vector 780 965 array index inner-string offset 781 966 (if (< count length) count length)) 782 967 (when (<= (decf length count) 0) 783 968 (return)) 784 (incf address (the fixnum (+ count wood::$block-overhead)))969 (incf address (the fixnum (+ count $block-overhead))) 785 970 (incf offset count)))))) 786 971 string) … … 789 974 ; non-array uvectors. 790 975 (defun lenient-array-data-and-offset (array) 791 (if # -ppc-target (eql $v_arrayh (%vect-subtype array))976 (if #+ccl-68k-target (eql $v_arrayh (%vect-subtype array)) 792 977 #+ppc-target (let ((typecode (ppc-typecode array))) 793 978 (declare (fixnum typecode)) 794 979 (or (eql typecode ppc::subtag-arrayh) 795 980 (eql typecode ppc::subtag-vectorh))) 981 #-ccl (arrayp array) 796 982 (array-data-and-offset array) 797 983 (values array 0))) 798 984 799 # -ppc-target985 #+ccl-68k-target 800 986 (defun uvector-bytes (uvector) 801 ( lap-inline (uvector)802 ( if# (eq (dtagp arg_z$t_vector))803 ( wtaerr arg_z 'uvector))804 ( move.l arg_zatemp0)805 ( vsize atemp0arg_z)806 ( mkintarg_z)))987 (ccl::lap-inline (uvector) 988 (ccl::if# (ccl::eq (ccl::dtagp ccl::arg_z ccl::$t_vector)) 989 (ccl::wtaerr ccl::arg_z 'ccl::uvector)) 990 (ccl::move.l ccl::arg_z ccl::atemp0) 991 (ccl::vsize ccl::atemp0 ccl::arg_z) 992 (ccl::mkint ccl::arg_z))) 807 993 808 994 #+ppc-target … … 816 1002 (ash length 2)))) 817 1003 818 (defun wood::load-byte-array (disk-cache address length byte-array &optional 819 (start 0) trust-me?) 1004 (defun-inline load-bytes-to-string (disk-cache address length string) 1005 (ensure-byte-array string) 1006 (if (> length (byte-vector-length string)) 1007 (error "(~s ~s) < ~s" 'byte-vector-length string length)) 1008 (load-bytes-to-ivector disk-cache address length string)) 1009 1010 (defun-inline load-bytes-to-bit-vector (disk-cache address num-bytes bitvector) 1011 (assert (typep bitvector '(simple-array (unsigned-byte 1) (*)))) 1012 (load-bytes-to-ivector disk-cache address num-bytes bitvector)) 1013 1014 (defun load-bytes-to-ivector (disk-cache address length ivector) 1015 (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*)) 1016 (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector) 1017 (let* ((subtype (uvector-subtype ivector)) 1018 (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype)) 1019 #+LispWorks (svref *subtype->array-byte-offset* subtype)))) 1020 (load-bytes-as-byte-vector disk-cache address length inner-array byte-offset))) 1021 ivector) 1022 1023 #+LispWorks 1024 (defun load-bytes-to-iarray (disk-cache address num-bytes array) 1025 ;; Array is a non-displaced array of immediate data. I won't even begin to guess at the 1026 ;; internal format. 1027 (let* ((num-elts (array-total-size array)) 1028 (ivector (make-array num-elts :element-type (array-element-type array)))) 1029 (load-bytes-to-ivector disk-cache address num-bytes ivector) 1030 (loop for i from 0 below num-elts 1031 do (setf (row-major-aref array i) (aref ivector i))) 1032 array)) 1033 1034 (defun load-bytes-as-byte-vector (disk-cache address length ivector byte-offset) 820 1035 (setq length (require-type length 'fixnum)) 821 (setq start (require-type start 'fixnum)) 822 (locally (declare (fixnum length)) 823 (when (> (+ address length) (wood::disk-cache-size disk-cache)) 1036 (setq byte-offset (require-type byte-offset 'fixnum)) 1037 (setq ivector (require-type ivector 'simple-array)) 1038 (locally (declare (fixnum length byte-offset)) 1039 (when (> (+ address length) (disk-cache-size disk-cache)) 824 1040 (error "Attempt to read past EOF")) 825 (multiple-value-bind (inner-array offset) 826 (lenient-array-data-and-offset byte-array) 827 (unless trust-me? ; for p-load-ivector 828 (ensure-byte-array byte-array) 829 (if (> (+ start length) (uvector-bytes byte-array)) 830 (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length)))) 831 (incf offset start) 832 (loop 833 (wood::with-databases-locked 834 (multiple-value-bind (array index count) 835 (wood::get-disk-page disk-cache address) 836 (declare (fixnum count index)) 837 #-ppc-target 838 (lap-inline () 839 (:variable array index count length inner-array offset) 840 (move.l (varg array) atemp0) 841 (move.l (varg index) da) 842 (getint da) 843 (lea (atemp0 da.l $v_data) atemp0) 844 (move.l (varg inner-array) atemp1) 845 (move.l (varg offset) da) 846 (getint da) 847 (lea (atemp1 da.l $v_data) atemp1) 848 (move.l (varg length) da) 849 (if# (gt (cmp.l (varg count) da)) 850 (move.l (varg count) da)) 851 (getint da) 852 (dbfloop.l da 853 (move.b atemp0@+ atemp1@+))) 854 #+ppc-target 855 (%copy-ivector-to-ivector 856 array index inner-array offset 857 (if (< count length) count length)) 858 (when (<= (decf length count) 0) 859 (return)) 860 (incf address (the fixnum (+ count wood::$block-overhead))) 861 (incf offset count)))))) 862 byte-array) 1041 (loop 1042 (with-databases-locked 1043 (multiple-value-bind (array index count) 1044 (get-disk-page disk-cache address) 1045 (declare (fixnum count index)) 1046 #+ccl-68k-target 1047 (ccl::lap-inline () 1048 (:variable array index count length ivector byte-offset) 1049 (ccl::move.l (ccl::varg array) ccl::atemp0) 1050 (ccl::move.l (ccl::varg index) ccl::da) 1051 (ccl::getint ccl::da) 1052 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1053 (ccl::move.l (ccl::varg ivector) ccl::atemp1) 1054 (ccl::move.l (ccl::varg byte-offset) ccl::da) 1055 (ccl::getint ccl::da) 1056 (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 1057 (ccl::move.l (ccl::varg length) ccl::da) 1058 (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 1059 (ccl::move.l (ccl::varg count) ccl::da)) 1060 (ccl::getint ccl::da) 1061 (ccl::dbfloop.l ccl::da 1062 (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))) 1063 #-ccl-68k-target 1064 (copy-as-byte-vector array index ivector byte-offset 1065 (if (< count length) count length)) 1066 (when (<= (decf length count) 0) 1067 (return)) 1068 (incf address (the fixnum (+ count $block-overhead))) 1069 (incf byte-offset count)))))) 1070 863 1071 864 1072 ; Copy length bytes from from at from-index to to at to-index. … … 867 1075 ; If either array is not a byte array or string, you will likely crash 868 1076 ; sometime in the future. 869 (defun wood::%copy-byte-array-portion (from from-index length to to-index &optional to-page)1077 (defun %copy-byte-array-portion (from from-index length to to-index &optional to-page) 870 1078 (declare (ignore to-page)) ; for logging/recovery 871 1079 (setq from-index (require-type from-index 'fixnum)) … … 875 1083 (when (> length 0) 876 1084 (unless (and (>= from-index 0) 877 (<= (the fixnum (+ from-index length)) ( uvector-bytesfrom))1085 (<= (the fixnum (+ from-index length)) (byte-vector-length from)) 878 1086 (>= to-index 0) 879 (<= (the fixnum (+ to-index length)) ( uvector-bytesto)))1087 (<= (the fixnum (+ to-index length)) (byte-vector-length to))) 880 1088 (error "Attempt to index off end of one of the arrays")) 881 1089 (multiple-value-bind (from off) (lenient-array-data-and-offset from) … … 885 1093 (ensure-byte-array from) 886 1094 (ensure-byte-array to) 887 # -ppc-target888 ( lap-inline ()1095 #+ccl-68k-target 1096 (ccl::lap-inline () 889 1097 (:variable from from-index length to to-index) 890 ( move.l (varg from)atemp0)891 ( move.l atemp0arg_x) ; arg_x = from892 ( move.l (varg from-index)da)893 ( getintda)894 ( move.l daarg_y) ; arg_y = from-index895 ( lea (atemp0 da.l $v_data)atemp0)896 ( move.l (varg to)atemp1)897 ( move.l atemp1arg_z) ; arg_z = to898 ( move.l (varg to-index)da)899 ( getintda)900 ( move.l dadb) ; db = to-index901 ( lea (atemp1 da.l $v_data)atemp1)902 ( move.l (varg length)da)903 ( getintda)1098 (ccl::move.l (ccl::varg from) ccl::atemp0) 1099 (ccl::move.l ccl::atemp0 ccl::arg_x) ; arg_x = from 1100 (ccl::move.l (ccl::varg from-index) ccl::da) 1101 (ccl::getint ccl::da) 1102 (ccl::move.l ccl::da ccl::arg_y) ; arg_y = from-index 1103 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1104 (ccl::move.l (ccl::varg to) ccl::atemp1) 1105 (ccl::move.l ccl::atemp1 ccl::arg_z) ; arg_z = to 1106 (ccl::move.l (ccl::varg to-index) ccl::da) 1107 (ccl::getint ccl::da) 1108 (ccl::move.l ccl::da ccl::db) ; db = to-index 1109 (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 1110 (ccl::move.l (ccl::varg length) ccl::da) 1111 (ccl::getint ccl::da) 904 1112 ; _BlockMove is slower for small moves 905 ( if# (gt (cmp.l ($ 128)da))906 ( move.l daacc)907 ( dc.w #_BlockMove)908 else#909 ( if# (and (eq (cmp.l arg_xarg_z))910 (gt (cmp.l arg_ydb)))911 ( add.l daatemp0)912 ( add.l daatemp1)913 ( dbfloop.lda914 ( move.b -@atemp0-@atemp1))915 else#916 ( dbfloop.lda917 ( move.b atemp0@+atemp1@+)))))918 # +ppc-target919 ( %copy-ivector-to-ivector1113 (ccl::if# (ccl::gt (ccl::cmp.l (ccl::$ 128) ccl::da)) 1114 (ccl::move.l ccl::da ccl::acc) 1115 (ccl::dc.w #_BlockMove) 1116 ccl::else# 1117 (ccl::if# (and (ccl::eq (ccl::cmp.l ccl::arg_x ccl::arg_z)) 1118 (ccl::gt (ccl::cmp.l ccl::arg_y ccl::db))) 1119 (ccl::add.l ccl::da ccl::atemp0) 1120 (ccl::add.l da ccl::atemp1) 1121 (ccl::dbfloop.l ccl::da 1122 (ccl::move.b ccl::-@atemp0 ccl::-@atemp1)) 1123 ccl::else# 1124 (ccl::dbfloop.l ccl::da 1125 (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))))) 1126 #-ccl-68k-target 1127 (copy-as-byte-vector 920 1128 from from-index to to-index length))))) 921 1129 to) 922 1130 923 (defun wood::%load-string (array index length &optional string)1131 (defun %load-string (array index length &optional string) 924 1132 (unless string 925 1133 (setq string (make-string length :element-type 'base-character))) 926 ( wood::%copy-byte-array-portion array index length string 0))927 928 (defun wood::%store-string (string array index &optional (length (length string)))929 ( wood::%copy-byte-array-portion string 0 length array index)1134 (%copy-byte-array-portion array index length string 0)) 1135 1136 (defun %store-string (string array index &optional (length (length string))) 1137 (%copy-byte-array-portion string 0 length array index) 930 1138 string) 931 1139 932 (defun (setf wood::read-string) (string disk-cache address &optional length)1140 (defun (setf read-string) (string disk-cache address &optional length) 933 1141 (if length 934 1142 (when (> (setq length (require-type length 'fixnum)) (length string)) 935 1143 (error "~s > the length of the string." 'length)) 936 1144 (setq length (length string))) 937 (unless (>= ( wood::disk-cache-size disk-cache)1145 (unless (>= (disk-cache-size disk-cache) 938 1146 (+ address length)) 939 ( wood::extend-disk-cache disk-cache (+ address length)))1147 (extend-disk-cache disk-cache (+ address length))) 940 1148 (multiple-value-bind (string offset) (array-data-and-offset string) 941 1149 (declare (fixnum offset)) 942 1150 (loop 943 (w ood::with-databases-locked1151 (with-databases-locked 944 1152 (multiple-value-bind (array index count) 945 ( wood::get-disk-page disk-cache address t)1153 (get-disk-page disk-cache address t) 946 1154 (declare (fixnum count index)) 947 # -ppc-target948 ( lap-inline ()1155 #+ccl-68k-target 1156 (ccl::lap-inline () 949 1157 (:variable array index count length string offset) 950 ( move.l (varg array)atemp0)951 ( move.l (varg index)da)952 ( getintda)953 ( lea (atemp0 da.l $v_data)atemp0)954 ( move.l (varg string)atemp1)955 ( move.l (varg offset)da)956 ( getintda)957 ( lea (atemp1 da.l $v_data)atemp1)958 ( move.l (varg length)da)959 ( if# (gt (cmp.l (varg count)da))960 ( move.l (varg count)da))961 ( getintda)962 ( dbfloop.lda963 ( move.b atemp1@+atemp0@+)))964 # +ppc-target965 ( %copy-ivector-to-ivector1158 (ccl::move.l (ccl::varg array) ccl::atemp0) 1159 (ccl::move.l (ccl::varg index) ccl::da) 1160 (ccl::getint ccl::da) 1161 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1162 (ccl::move.l (ccl::varg string) ccl::atemp1) 1163 (ccl::move.l (ccl::varg offset) ccl::da) 1164 (ccl::getint ccl::da) 1165 (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 1166 (ccl::move.l (ccl::varg length) ccl::da) 1167 (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 1168 (ccl::move.l (ccl::varg count) ccl::da)) 1169 (ccl::getint ccl::da) 1170 (ccl::dbfloop.l ccl::da 1171 (ccl::move.b ccl::atemp1@+ ccl::atemp0@+))) 1172 #-ccl-68k-target 1173 (copy-as-byte-vector 966 1174 string offset array index 967 1175 (if (< count length) count length)) … … 972 1180 string) 973 1181 974 (defun wood::store-byte-array (byte-array disk-cache address length &optional 975 (start 0) trust-me?) 1182 1183 (defun-inline store-bytes-from-string (byte-array disk-cache address length) 1184 (ensure-byte-array byte-array) 1185 (store-bytes-from-ivector byte-array disk-cache address length)) 1186 1187 (defun-inline store-bytes-from-bit-vector (bitvector disk-cache address length) 1188 (assert (typep bitvector '(simple-array (unsigned-byte 1) (*)))) 1189 (store-bytes-from-ivector bitvector disk-cache address length)) 1190 1191 (defun store-bytes-from-ivector (ivector disk-cache address length) 1192 (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*)) 1193 (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector) 1194 (let* ((subtype (uvector-subtype ivector)) 1195 (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype)) 1196 #+LispWorks (svref *subtype->array-byte-offset* subtype)))) 1197 (store-bytes-as-byte-vector inner-array disk-cache address length byte-offset)))) 1198 1199 #+LispWorks 1200 (defun store-bytes-from-iarray (array disk-cache address num-bytes) 1201 ;; Array is a non-displaced array of immediate data. I won't even begin to guess at the 1202 ;; internal format. 1203 (let* ((num-elts (array-total-size array)) 1204 (ivector (make-array num-elts :element-type (array-element-type array)))) 1205 (loop for i from 0 below num-elts 1206 do (setf (aref ivector i) (row-major-aref array i))) 1207 (store-bytes-from-ivector ivector disk-cache address num-bytes) 1208 array)) 1209 1210 1211 (defun store-bytes-as-byte-vector (byte-array disk-cache address length start) 976 1212 (setq length (require-type length 'fixnum)) 977 1213 (setq start (require-type start 'fixnum)) 978 1214 (locally (declare (fixnum length)) 979 (when (> (+ address length) ( wood::disk-cache-size disk-cache))1215 (when (> (+ address length) (disk-cache-size disk-cache)) 980 1216 (error "Attempt to read past EOF")) 981 1217 (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset byte-array) 982 (unless trust-me? ; for p-load-ivector983 (ensure-byte-array byte-array)984 (if (> (+ start length) (uvector-bytes byte-array))985 (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length))))986 1218 (incf offset start) 987 1219 (loop 988 (w ood::with-databases-locked1220 (with-databases-locked 989 1221 (multiple-value-bind (array index count) 990 ( wood::get-disk-page disk-cache address t)1222 (get-disk-page disk-cache address t) 991 1223 (declare (fixnum count index)) 992 # -ppc-target993 ( lap-inline ()1224 #+ccl-68k-target 1225 (ccl::lap-inline () 994 1226 (:variable array index count length inner-array offset) 995 ( move.l (varg array)atemp0)996 ( move.l (varg index)da)997 ( getintda)998 (lea ( atemp0 da.l $v_data)atemp0)999 ( move.l (varg inner-array)atemp1)1000 ( move.l (varg offset)da)1001 ( getintda)1002 ( lea (atemp1 da.l $v_data)atemp1)1003 ( move.l (varg length)da)1004 ( if# (gt (cmp.l (varg count)da))1005 ( move.l (varg count)da))1006 ( getintda)1007 ( dbfloop.lda1008 ( move.b atemp1@+atemp0@+)))1009 # +ppc-target1010 ( %copy-ivector-to-ivector1227 (ccl::move.l (ccl::varg array) ccl::atemp0) 1228 (ccl::move.l (ccl::varg index) ccl::da) 1229 (ccl::getint ccl::da) 1230 (lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1231 (ccl::move.l (ccl::varg inner-array) ccl::atemp1) 1232 (ccl::move.l (ccl::varg offset) ccl::da) 1233 (ccl::getint ccl::da) 1234 (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 1235 (ccl::move.l (ccl::varg length) ccl::da) 1236 (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 1237 (ccl::move.l (ccl::varg count) ccl::da)) 1238 (ccl::getint ccl::da) 1239 (ccl::dbfloop.l ccl::da 1240 (ccl::move.b ccl::atemp1@+ ccl::atemp0@+))) 1241 #-ccl-68k-target 1242 (copy-as-byte-vector 1011 1243 inner-array offset array index 1012 1244 (if (< count length) count length)) 1013 1245 (when (<= (decf length count) 0) 1014 1246 (return)) 1015 (incf address (the fixnum (+ count wood::$block-overhead)))1247 (incf address (the fixnum (+ count $block-overhead))) 1016 1248 (incf offset count)))))) 1017 1249 byte-array) 1018 1250 1019 (defun wood::fill-long (disk-cache address value count &optional immediate?) 1251 1252 (defun fill-long (disk-cache address value count &optional immediate?) 1020 1253 (let ((count (require-type count 'fixnum))) 1021 1254 (declare (fixnum count)) 1022 1255 (unless (eql 0 (logand 1 address)) 1023 1256 (error "Odd address: ~s" address)) 1024 (when (<= count 0) (return-from wood::fill-long) nil)1257 (when (<= count 0) (return-from fill-long) nil) 1025 1258 (let ((min-size (+ address (ash count 2)))) 1026 (when (< ( wood::disk-cache-size disk-cache) min-size)1027 ( wood::extend-disk-cache disk-cache min-size)))1259 (when (< (disk-cache-size disk-cache) min-size) 1260 (extend-disk-cache disk-cache min-size))) 1028 1261 (loop 1029 (w ood::with-databases-locked1262 (with-databases-locked 1030 1263 (multiple-value-bind (vector offset size) 1031 ( wood::get-disk-page disk-cache address t)1264 (get-disk-page disk-cache address t) 1032 1265 (declare (fixnum offset size)) 1033 1266 (when (<= size 0) … … 1036 1269 (declare (fixnum words)) 1037 1270 (if (< count words) (setq words count)) 1038 # -ppc-target1039 ( lap-inline ()1271 #+ccl-68k-target 1272 (ccl::lap-inline () 1040 1273 (:variable vector offset words value immediate?) 1041 ( move.l (varg value)arg_z)1042 ( if# (eq (cmp.l (varg immediate?)nilreg))1043 ( jsr_subprim$sp-getxlong)1044 else#1045 ( movereg arg_zacc))1046 ( move.l (varg vector)atemp0)1047 ( move.l (varg offset)da)1048 ( getintda)1049 ( lea (atemp0 da.l $v_data)atemp0)1050 ( move.l (varg words)da)1051 ( getintda)1052 ( dbfloop.l da (move.l accatemp0@+)))1053 # +ppc-target1274 (ccl::move.l (ccl::varg value) ccl::arg_z) 1275 (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 1276 (ccl::jsr_subprim ccl::$sp-getxlong) 1277 ccl::else# 1278 (ccl::movereg ccl::arg_z ccl::acc)) 1279 (ccl::move.l (ccl::varg vector) ccl::atemp0) 1280 (ccl::move.l (ccl::varg offset) ccl::da) 1281 (ccl::getint ccl::da) 1282 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1283 (ccl::move.l (ccl::varg words) ccl::da) 1284 (ccl::getint ccl::da) 1285 (ccl::dbfloop.l ccl::da (ccl::move.l ccl::acc ccl::atemp0@+))) 1286 #-ccl-68k-target 1054 1287 (if immediate? 1055 1288 (dotimes (i words) 1056 ( wood::%%store-pointer value vector offset t)1289 (%%store-pointer value vector offset t) 1057 1290 (incf offset 4)) 1058 1291 (dotimes (i words) … … 1060 1293 (incf offset 4))) 1061 1294 (if (<= (decf count words) 0) (return))) 1062 (incf address (the fixnum (+ size wood::$block-overhead))))))))1063 1064 (defun wood::fill-word (disk-cache address value count &optional immediate?)1295 (incf address (the fixnum (+ size $block-overhead)))))))) 1296 1297 (defun fill-word (disk-cache address value count &optional immediate?) 1065 1298 (declare (ignore immediate?)) 1066 1299 (let ((count (require-type count 'fixnum)) … … 1070 1303 (unless (eql 0 (logand 1 address)) 1071 1304 (error "Odd address: ~s" address)) 1072 (when (<= count 0) (return-from wood::fill-word) nil)1305 (when (<= count 0) (return-from fill-word) nil) 1073 1306 (let ((min-size (+ address (ash count 1)))) 1074 (when (< ( wood::disk-cache-size disk-cache) min-size)1075 ( wood::extend-disk-cache disk-cache min-size)))1307 (when (< (disk-cache-size disk-cache) min-size) 1308 (extend-disk-cache disk-cache min-size))) 1076 1309 (loop 1077 (w ood::with-databases-locked1310 (with-databases-locked 1078 1311 (multiple-value-bind (vector offset size) 1079 ( wood::get-disk-page disk-cache address t)1312 (get-disk-page disk-cache address t) 1080 1313 (declare (fixnum offset size)) 1081 1314 (when (<= size 0) … … 1084 1317 (declare (fixnum words)) 1085 1318 (if (< count words) (setq words count)) 1086 # -ppc-target1087 ( lap-inline ()1319 #+ccl-68k-target 1320 (ccl::lap-inline () 1088 1321 (:variable vector offset words value) 1089 ( move.l (varg vector)atemp0)1090 ( move.l (varg offset)da)1091 ( getintda)1092 ( lea (atemp0 da.l $v_data)atemp0)1093 ( move.l (varg words)da)1094 ( getintda)1095 ( move.l (varg value)acc)1096 ( getintacc)1097 ( dbfloop.l da (move.w accatemp0@+)))1322 (ccl::move.l (ccl::varg vector) ccl::atemp0) 1323 (ccl::move.l (ccl::varg offset) ccl::da) 1324 (ccl::getint ccl::da) 1325 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1326 (ccl::move.l (ccl::varg words) ccl::da) 1327 (ccl::getint ccl::da) 1328 (ccl::move.l (ccl::varg value) ccl::acc) 1329 (ccl::getint ccl::acc) 1330 (ccl::dbfloop.l ccl::da (ccl:move.w ccl::acc ccl::atemp0@+))) 1098 1331 #+ppc-target 1099 1332 (locally (declare (type (simple-array (unsigned-byte 16) (*)) vector) … … 1104 1337 (setf (aref vector word-offset) value) 1105 1338 (incf word-offset)))) 1339 #-ccl 1340 (dotimes (i words) 1341 (%%store-word value vector offset) 1342 (incf offset 2)) 1106 1343 (if (<= (decf count words) 0) (return))) 1107 (incf address (the fixnum (+ size wood::$block-overhead))))))))1108 1109 (defun wood::fill-byte (disk-cache address value count &optional immediate?)1344 (incf address (the fixnum (+ size $block-overhead)))))))) 1345 1346 (defun fill-byte (disk-cache address value count &optional immediate?) 1110 1347 (declare (ignore immediate?)) 1111 1348 (let ((count (require-type count 'fixnum)) … … 1113 1350 (value (require-type value 'fixnum))) 1114 1351 (declare (fixnum count)) 1115 (when (<= count 0) (return-from wood::fill-byte) nil)1352 (when (<= count 0) (return-from fill-byte) nil) 1116 1353 (let ((min-size (+ address count))) 1117 (when (< ( wood::disk-cache-size disk-cache) min-size)1118 ( wood::extend-disk-cache disk-cache min-size)))1354 (when (< (disk-cache-size disk-cache) min-size) 1355 (extend-disk-cache disk-cache min-size))) 1119 1356 (loop 1120 (w ood::with-databases-locked1357 (with-databases-locked 1121 1358 (multiple-value-bind (vector offset size) 1122 ( wood::get-disk-page disk-cache address t)1359 (get-disk-page disk-cache address t) 1123 1360 (declare (fixnum offset size)) 1124 1361 (when (<= size 0) 1125 1362 (error "attempt to write past end of ~s" disk-cache)) 1126 1363 (if (< count size) (setq size count)) 1127 # -ppc-target1128 ( lap-inline ()1364 #+ccl-68k-target 1365 (ccl::lap-inline () 1129 1366 (:variable vector offset size value) 1130 ( move.l (varg vector)atemp0)1131 ( move.l (varg offset)da)1132 ( getintda)1133 ( lea (atemp0 da.l $v_data)atemp0)1134 ( move.l (varg size)da)1135 ( getintda)1136 ( move.l (varg value)acc)1137 ( getintacc)1138 ( dbfloop.l da (move.b accatemp0@+)))1139 # +ppc-target1367 (ccl::move.l (ccl::varg vector) ccl::atemp0) 1368 (ccl::move.l (ccl::varg offset) ccl::da) 1369 (ccl::getint ccl::da) 1370 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1371 (ccl::move.l (ccl::varg size) ccl::da) 1372 (ccl::getint ccl::da) 1373 (ccl::move.l (ccl::varg value) ccl::acc) 1374 (ccl::getint ccl::acc) 1375 (ccl::dbfloop.l ccl::da (ccl::move.b ccl::acc ccl::atemp0@+))) 1376 #-ccl-68k-target 1140 1377 (locally (declare (type (simple-array (unsigned-byte 8) (*)) vector) 1141 1378 (optimize (speed 3) (safety 0))) … … 1144 1381 (incf offset))) 1145 1382 (if (<= (decf count size) 0) (return)) 1146 (incf address (the fixnum (+ size wood::$block-overhead))))))))1147 1148 (defun wood::array-fill-long (array address value count &optional immediate?)1383 (incf address (the fixnum (+ size $block-overhead)))))))) 1384 1385 (defun array-fill-long (array address value count &optional immediate?) 1149 1386 (ensure-byte-array array) 1150 1387 (let ((count (require-type count 'fixnum)) … … 1155 1392 (unless (eql 0 (the fixnum (logand 1 address))) 1156 1393 (error "Odd address: ~s" address)) 1157 # -ppc-target1158 ( lap-inline ()1394 #+ccl-68k-target 1395 (ccl::lap-inline () 1159 1396 (:variable array address value count immediate?) 1160 ( move.l (varg array)atemp0)1161 ( move.l (varg value)acc)1162 ( if# (eq (cmp.l (varg immediate?)nilreg))1163 ( movereg accarg_z)1164 ( jsr_subprim$sp-getxlong))1165 ( move.l (varg address)da)1166 ( getintda)1167 ( lea (atemp0 da.l $v_data)atemp0)1168 ( move.l (varg count)da)1169 ( dbfloop.l da (move.l accatemp0@+)))1170 # +ppc-target1397 (ccl::move.l (ccl::varg array) ccl::atemp0) 1398 (ccl::move.l (ccl::varg value) ccl::acc) 1399 (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 1400 (ccl::movereg ccl::acc ccl::arg_z) 1401 (ccl::jsr_subprim ccl::$sp-getxlong)) 1402 (ccl::move.l (ccl::varg address) ccl::da) 1403 (ccl::getint ccl::da) 1404 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1405 (ccl::move.l (ccl::varg count) ccl::da) 1406 (ccl::dbfloop.l ccl::da (ccl::move.l ccl::acc ccl::atemp0@+))) 1407 #-ccl-68k-target 1171 1408 (let ((offset address)) 1172 1409 (declare (fixnum offset)) 1173 1410 (if immediate? 1174 1411 (dotimes (i count) 1175 ( wood::%%store-pointer value array offset t)1412 (%%store-pointer value array offset t) 1176 1413 (incf offset 4)) 1177 1414 (dotimes (i count) … … 1180 1417 nil) 1181 1418 1182 (defun wood::array-fill-word (array address value count)1419 (defun array-fill-word (array address value count) 1183 1420 (ensure-byte-array array) 1184 1421 (let ((count (require-type count 'fixnum)) … … 1189 1426 (unless (eql 0 (the fixnum (logand 1 address))) 1190 1427 (error "Odd address: ~s" address)) 1191 # -ppc-target1192 ( lap-inline ()1428 #+ccl-68k-target 1429 (ccl::lap-inline () 1193 1430 (:variable array address value count) 1194 ( move.l (varg array)atemp0)1195 ( move.l (varg value)acc)1196 ( getintacc)1197 ( move.l (varg address)da)1198 ( getintda)1199 ( lea (atemp0 da.l $v_data)atemp0)1200 ( move.l (varg count)da)1201 ( dbfloop.l da (move.w accatemp0@+)))1431 (ccl::move.l (ccl::varg array) ccl::atemp0) 1432 (ccl::move.l (ccl::varg value) ccl::acc) 1433 (ccl::getint ccl::acc) 1434 (ccl::move.l (ccl::varg address) ccl::da) 1435 (ccl::getint ccl::da) 1436 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1437 (ccl::move.l (ccl::varg count) ccl::da) 1438 (ccl::dbfloop.l ccl::da (ccl::move.w ccl::acc ccl::atemp0@+))) 1202 1439 #+ppc-target 1203 1440 (let ((index (ash address -1))) … … 1207 1444 (dotimes (i count) 1208 1445 (setf (aref array index) value) 1209 (incf index)))) 1446 (incf index))) 1447 #-ccl 1448 (dotimes (i count) 1449 (declare (fixnum i)) 1450 (%%store-word value array address) 1451 (incf address 2))) 1210 1452 nil) 1211 1453 1212 (defun wood::array-fill-byte (array address value count)1454 (defun array-fill-byte (array address value count) 1213 1455 (ensure-byte-array array) 1214 1456 (let ((count (require-type count 'fixnum)) … … 1217 1459 (declare (fixnum count address)) 1218 1460 (check-byte-array-address address count array) 1219 # -ppc-target1220 ( lap-inline ()1461 #+ccl-68k-target 1462 (ccl::lap-inline () 1221 1463 (:variable array address value count) 1222 ( move.l (varg array)atemp0)1223 ( move.l (varg value)acc)1224 ( getintacc)1225 ( move.l (varg address)da)1226 ( getintda)1227 ( lea (atemp0 da.l $v_data)atemp0)1228 ( move.l (varg count)da)1229 ( getintda)1230 ( dbfloop.l da (move.b accatemp0@+)))1231 # +ppc-target1464 (ccl::move.l (ccl::varg array) ccl::atemp0) 1465 (ccl::move.l (ccl::varg value) ccl::acc) 1466 (ccl::getint ccl::acc) 1467 (ccl::move.l (ccl::varg address) ccl::da) 1468 (ccl::getint ccl::da) 1469 (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 1470 (ccl::move.l (ccl::varg count) ccl::da) 1471 (ccl::getint ccl::da) 1472 (ccl::dbfloop.l ccl::da (ccl::move.b ccl::acc ccl::atemp0@+))) 1473 #-ccl-68k-target 1232 1474 (let ((offset address)) 1233 1475 (declare (fixnum offset) … … 1241 1483 1242 1484 ; some macros to make using this take less typing. 1243 1244 (in-package :wood)1245 1246 1485 (export '(accessing-disk-cache)) 1247 1486 … … 1281 1520 (defun ensure-accessing-disk-cache (accessor env) 1282 1521 (unless (and (eq :lexical (variable-information '-*dc*- env)) 1283 (eq :macro (function-information '-*addr*- env)) 1284 (eq :macro (function-information '-*select*- env))) 1285 (error "~s called ouside of ~s environment" 1286 accessor 'accessing-disk-cache))) 1522 #-LispWorks (eq :macro (function-information '-*addr*- env)) 1523 #-LispWorks (eq :macro (function-information '-*select*- env))) 1524 (error "~s called ouside of ~s environment" accessor 'accessing-disk-cache))) 1287 1525 1288 1526 (defmacro load.l (address &environment env) … … 1430 1668 1431 1669 #| 1670 (close-disk-cache dc) 1432 1671 (setq wood::dc (wood::open-disk-cache "temp.dc" 1433 1672 :if-exists :overwrite … … 1457 1696 (require :lapmacros) 1458 1697 1459 (defun wood::time-moves (&optional (count 100))1698 (defun time-moves (&optional (count 100)) 1460 1699 (setq count (require-type count 'fixnum)) 1461 1700 (macrolet ((moves (count) 1462 `( lap-inline (,count)1463 ( getintarg_z)1464 ( move.l ($ 0)atemp0)1465 ( dbflooparg_z1701 `(ccl::lap-inline (,count) 1702 (ccl::getint ccl::arg_z) 1703 (ccl::move.l (ccl::$ 0) ccl::atemp0) 1704 (ccl::dbfloop ccl::arg_z 1466 1705 ,@(make-list 1000 1467 1706 :initial-element 1468 '( move.l atemp0@+da))))))1707 '(ccl::move.l ccl::atemp0@+ ccl::da)))))) 1469 1708 (moves count) 1470 1709 (* count 1000))) -
lw-branch/disk-cache.lisp
r3 r6 6 6 ;; Code to support a cached byte I/O stream. 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 21 22 ;; Modification History 22 23 ;; 24 ;; 02/01/06 gz LispWorks port 23 25 ;; ------------- 0.96 24 26 ;; ------------- 0.95 … … 100 102 ;; 101 103 102 (defpackage :wood)103 104 (in-package :wood) 104 105 … … 274 275 (setf (disk-page-flags disk-page) 275 276 (if value 276 ( ccl::bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page))277 ( ccl::bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page))))277 (%bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page)) 278 (%bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page)))) 278 279 (not (null value)))) 279 280 … … 290 291 (setf (disk-page-flags disk-page) 291 292 (if value 292 ( ccl::bitset $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page)))293 ( ccl::bitclr $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page)))))293 (%bitset $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))) 294 (%bitclr $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))))) 294 295 value) 295 296 … … 319 320 ; New code 320 321 (defparameter *big-io-buffers* 321 (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open))))) 322 #+ccl (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open)))) 323 #+LispWorks nil) 322 324 323 325 (defun open-disk-cache (filename &key shared-p read-only-p … … 330 332 (if-does-not-exist :error) 331 333 (external-format :???? ef-p) 332 (mac-file-creator :ccl2)334 #+ccl (mac-file-creator :ccl2) 333 335 write-hook 334 336 (initial-transaction-p t)) … … 346 348 (setq max-pages (shared-buffer-max-pages shared-buffer)) 347 349 (let ((mask (lognot (1- (expt 2 (1- (integer-length page-size))))))) 350 #+ccl 348 351 (if (probe-file filename) 349 352 (if (and ef-p (neq external-format (mac-file-type filename))) … … 359 362 :if-exists if-exists 360 363 :if-does-not-exist if-does-not-exist 361 :mac-file-creator mac-file-creator 364 #+ccl :mac-file-creator #+ccl mac-file-creator 365 #+LispWorks :element-type '(unsigned-byte 8) 362 366 rest))) 363 367 (when stream … … 525 529 (unless (fixnump address) 526 530 (error "Address is not a fixnum")) 527 (locally #+wood-fixnum-addresses528 (declare (fixnum address))531 (locally 532 #+wood-fixnum-addresses (declare (fixnum address)) 529 533 (let* ((hash (disk-cache-page-hash disk-cache)) 530 534 (base-address (logand address (the fixnum (disk-cache-mask disk-cache)))) … … 540 544 (shared-buffer (disk-cache-shared-buffer disk-cache))) 541 545 #+wood-fixnum-addresses (declare (fixnum max-size)) 542 ( if(>= address max-size)546 (when (>= address max-size) 543 547 (if (> address max-size) 544 548 (error "~s > size of ~s" address disk-cache) … … 560 564 (setq page (shared-buffer-pages shared-buffer))) 561 565 ;; Here's the page replacement algorithm, one-bit clock algorithm 562 (loop 566 (loop ; while disk-page-touched? 563 567 (unless (disk-page-touched? page) (return)) 564 568 (setf (disk-page-touched? page) nil) … … 669 673 (if address 670 674 (let (ignored-params) 671 (multiple-value-bind (body-tail decls) ( ccl::parse-body body env nil)675 (multiple-value-bind (body-tail decls) (parse-body body env nil) 672 676 (flet ((normalize (param &optional (ignoreable? t)) 673 677 (or param … … 718 722 ; increase the file size & install the new size 719 723 (when extend-file? 720 ( file-length (disk-cache-stream disk-cache) new-size))724 (extend-file-length (disk-cache-stream disk-cache) new-size)) 721 725 (setf (disk-cache-size disk-cache) new-size))))) 722 726 … … 727 731 (flush-disk-cache dc)))) 728 732 729 ( pushnew 'flush-all-disk-caches *lisp-cleanup-functions*)733 (register-lisp-cleanup-function 'flush-all-disk-caches) 730 734 731 735 ;;;;;;;;;;;;;;;;;;;;;;; … … 794 798 (incf address bytes))))) 795 799 796 ; write a string to dc797 800 (defun wc (string address) 798 801 (declare (special dc)) -
lw-branch/disk-page-hash.lisp
r3 r6 6 6 ;; A simple and very fast hashing mechanism for disk pages 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996-1999 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 27 28 ;; Modification History 28 29 ;; 30 ;; 02/01/06 gz LispWorks port 29 31 ;; 01/10/00 akh moved (pushnew :wood-fixnum-addresses *features*) to block-io-mcl 30 32 ;; -------- 0.96 … … 147 149 hash) 148 150 149 (declaim (inline address-iasr)) 150 151 (defun address-iasr (count address &optional known-fixnum-p) 152 (declare (fixnum count)) 153 #+wood-fixnum-addresses (declare (fixnum address) (ignore known-fixnum-p)) 154 (if #+wood-fixnum-addresses t 155 #-wood-fixnum-addresses known-fixnum-p 156 (ccl::%iasr count address) 157 (ash address (the fixnum (- 0 count))))) 151 #+wood-fixnum-addresses 152 (defun-inline address-iasr (count address) 153 (declare (fixnum count address)) 154 (the fixnum (%iasr count address))) 155 156 #-wood-fixnum-addresses 157 (defun-inline address-iasr (count address) 158 (declare (fixnum count) 159 (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 160 #-LispWorks 161 (the fixnum (ash address (the fixnum (- 0 count)))) 162 #+LispWorks 163 (the fixnum (sys:int32-to-integer (sys:int32>> (the integer address) count)))) 164 158 165 159 166 ; I wanted this to be an inlined function, but MCL's compiler wouldn't inline the knowledge 160 167 ; that address was a fixnum. 161 168 (defmacro %disk-page-gethash-macro (address hash &optional fixnum-address?) 162 `(locally (declare (optimize (speed 3) (safety 0))) 169 `(locally (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)) 170 ,@(and fixnum-address? '((type fixnum address)))) 163 171 (if (eql ,address (disk-page-hash-cache-address ,hash)) 164 172 (disk-page-hash-cache-value ,hash) 165 (let* ((page-number (address-iasr (disk-page-hash-page-size-shift ,hash) ,address ,fixnum-address?)) 173 (let* ((page-number ,(if fixnum-address? 174 `(%iasr (disk-page-hash-page-size-shift ,hash) ,address) 175 `(address-iasr (disk-page-hash-page-size-shift ,hash) ,address))) 166 176 (hash-code (logand page-number (the fixnum (disk-page-hash-mask ,hash)))) 167 (index ( * 2hash-code))177 (index (+ hash-code hash-code)) 168 178 (vector (disk-page-hash-vector ,hash)) 169 179 (probe (svref vector index))) 170 (declare (fixnum hash-code index p robe ,@(and fixnum-address? '(page-number)))180 (declare (fixnum hash-code index page-number) 171 181 (type simple-vector vector)) 172 182 (cond ((eql probe ,address) (aref vector (the fixnum (1+ index)))) 173 ((eq lprobe *no-key-marker*) nil)183 ((eq probe *no-key-marker*) nil) 174 184 (t (let ((secondary-key (aref *secondary-keys* 175 ( ccl::%iasr (disk-page-hash-shift ,hash)176 185 (%iasr (disk-page-hash-shift ,hash) 186 (logand page-number (the fixnum (disk-page-hash-secondary-mask ,hash)))))) 177 187 (vector-length (disk-page-hash-vector-length ,hash)) 178 188 (original-index index)) … … 187 197 (when (eql probe ,address) 188 198 (let ((value (aref vector (the fixnum (1+ index))))) 189 (setf (disk-page-hash-cache-address hash)address190 (disk-page-hash-cache-value hash) value191 (disk-page-hash-cache-index hash) index)199 (setf (disk-page-hash-cache-address ,hash) ,address 200 (disk-page-hash-cache-value ,hash) value 201 (disk-page-hash-cache-index ,hash) index) 192 202 (return value))) 193 (when (eq lprobe *no-key-marker*)203 (when (eq probe *no-key-marker*) 194 204 (return nil))))))))))) 205 206 #| 207 ;(disassemble #'fixnum-disk-page-gethash) 208 (defun fixnum-disk-page-gethash (address hash) 209 (declare (type fixnum address)) 210 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 211 (%disk-page-gethash-macro address hash t)) 212 |# 195 213 196 214 ; This is one of WOOD's most-called functions. 197 215 ; It's important that it be as fast as possible. 198 (defun disk-page-gethash (address hash) 199 (declare (optimize (speed 3) (safety 0))) 216 (defun disk-page-gethash (address hash #+LispWorks &optional #+LispWorks ignore) 217 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 218 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 200 219 ; Assume if it's non-null that it's of the right type since 201 220 ; type check takes too long (unless unlined LAP?). … … 204 223 (unless hash 205 224 (error "Null hash table.")) 206 (if #+wood-fixnum-addresses t 207 #-wood-fixnum-addresses (fixnump address) 225 (if #+wood-fixnum-addresses t #-wood-fixnum-addresses (fixnump address) 208 226 (locally (declare (fixnum address)) 209 227 (%disk-page-gethash-macro address hash t)) … … 211 229 212 230 (defun (setf disk-page-gethash) (value address hash &optional deleting?) 231 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 213 232 #+wood-fixnum-addresses (declare (fixnum address)) 214 233 (unless (typep hash 'disk-page-hash) … … 219 238 (if deleting? 220 239 (let ((vector (disk-page-hash-vector hash))) 221 (setf (disk-page-hash-cache-address hash) nil 240 (setf (disk-page-hash-cache-address hash) nil ; 222 241 (disk-page-hash-cache-value hash) nil 223 242 (disk-page-hash-cache-index hash) nil … … 240 259 (eql probe *no-key-marker*) 241 260 (let ((secondary-key (aref *secondary-keys* 242 ( ccl::%iasr (disk-page-hash-shift hash)243 261 (%iasr (disk-page-hash-shift hash) 262 (logand page-number (the fixnum (disk-page-hash-secondary-mask hash)))))) 244 263 (vector-length (length vector)) 245 264 (first-deletion nil) … … 299 318 (declare (fixnum index length)) 300 319 (loop 301 (let ((key ( ccl::%svref vector index))302 (value ( ccl::%svref vector (incf index))))320 (let ((key (%svref vector index)) 321 (value (%svref vector (incf index)))) 303 322 (incf index) 304 323 (unless (or (eql key *no-key-marker*) (eql key *deleted-key-marker*)) … … 323 342 ; takes a long time, so we get rid of the delted markers to speed it up. 324 343 (defun disk-page-rehash (hash address value) 344 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 325 345 (locally 326 346 (declare (optimize (speed 3) (safety 0))) … … 340 360 (declare (type simple-vector vector) 341 361 (fixnum vector-length page-size-shift mask shift secondary-mask loop-index loop-index+1)) 342 #-wood-fixnum-addresses (declare (fixnum minus-page-size-shift))343 362 (flet ((bit-ref (bits index) 344 363 (declare (type (simple-array (unsigned-byte 8) (*)) bits) … … 395 414 (setf (bit-ref bits index) 1)) 396 415 (t nil))))) 397 (declare (dynamic-extent insert-p))416 (declare (dynamic-extent #'insert-p)) 398 417 (unless (insert-p (svref vector index)) 399 418 (let ((secondary-key (aref *secondary-keys* 400 ( ccl::%iasr shift (logand page-number secondary-mask)))))419 (%iasr shift (logand page-number secondary-mask))))) 401 420 (declare (fixnum secondary-key)) 402 421 (loop -
lw-branch/example.lisp
r3 r6 1 ;;;-*- Mode: Lisp; Package: cl-user 1 ;;;-*- Mode: Lisp; Package: cl-user -*- 2 2 ;;; 3 3 ;;; example.lisp … … 101 101 102 102 (defun store-person (pheap person) 103 (setq person ( require-type person 'person))103 (setq person (wood::require-type person 'person)) 104 104 (multiple-value-bind (ss#->person last-name->person-list) 105 105 (person-pheap-tables pheap) … … 125 125 (wood:p-btree-lookup last-name->person-list (string-upcase last-name))))) 126 126 127 (defun print-people-by-ss# (pheap) 128 (let ((ss#->person (person-pheap-tables pheap))) 127 (defun print-people-by-ss# (pheap &optional (stream t)) 128 (let ((ss#->person (person-pheap-tables pheap)) 129 (index -1)) 129 130 (wood:p-map-btree ss#->person 130 131 #'(lambda (ss# person) 131 (format t "~&~a ~s~%" ss# (wood:p-load person)))))) 132 133 (defun print-people-by-last-name (pheap) 132 (format stream "~&#~2,' d: ~a ~s~%" 133 (incf index) 134 ss# (wood:p-load person)))))) 135 136 (defun print-people-by-last-name (pheap &optional (stream t)) 134 137 (multiple-value-bind (ss#->person last-name->person-list) 135 138 (person-pheap-tables pheap) … … 144 147 :key 'person-first-name)) 145 148 (dolist (person person-list) 146 (format t"~&~s~%" person))))))149 (format stream "~&~s~%" person)))))) 147 150 148 151 ;; Code for creating random PERSON instances. … … 217 220 218 221 #| 222 (defun listener-stream () 223 "Find the stream to the listener's main pane." 224 (let* ((listener (capi:locate-interface 'lispworks-tools:listener)) 225 (pane (and listener (capi:interface-editor-pane listener))) 226 (stream (and pane (capi:interactive-pane-stream pane)))) 227 stream)) 228 229 (defvar *random-people* (loop for i from 0 below 100 collect (random-person))) 230 (let ((stream (listener-stream))) 231 (loop for p in (subseq *random-people* 0 18) 232 do (format stream "~& (make-instance 'person :first-name ~s :last-name ~s :age ~s :sex '~s :occupation ~s :ss# ~s)" 233 (person-first-name p) (person-last-name p) (person-age p) 234 (person-sex p) (person-occupation p) (person-ss# p)))) 235 236 (defparameter *people* 237 (list 238 (make-instance 'person :first-name "Melissa" :last-name "Smith" :age #x60 :sex '\F :occupation "Cop" :ss# "232436212") 239 (make-instance 'person :first-name "Matthew" :last-name "Wilson" :age #x5D :sex 'M :occupation "Candlestick Maker" :ss# "859110137") 240 (make-instance 'person :first-name "Steve" :last-name "Johnson" :age #x1 :sex 'M :occupation "Cashier" :ss# "140739951") 241 (make-instance 'person :first-name "Gail" :last-name "Wilson" :age #x4A :sex '\F :occupation "Baker" :ss# "209354283") 242 (make-instance 'person :first-name "Dan" :last-name "Johnson" :age #x4 :sex 'M :occupation "Hacker" :ss# "809159982") 243 (make-instance 'person :first-name "Melissa" :last-name "Jones" :age #x3 :sex '\F :occupation "Doctor" :ss# "672195544") 244 (make-instance 'person :first-name "Alice" :last-name "Riley" :age #x4F :sex '\F :occupation "Dentist" :ss# "218397663") 245 (make-instance 'person :first-name "Hillary" :last-name "Riley" :age #x2D :sex '\F :occupation "Insurance Sales" :ss# "573610849") 246 (make-instance 'person :first-name "Andrew" :last-name "Peterson" :age #x5 :sex 'M :occupation "Engineer" :ss# "714724948") 247 (make-instance 'person :first-name "Christie" :last-name "Kennedy" :age #x1E :sex '\F :occupation "Butcher" :ss# "677765239") 248 (make-instance 'person :first-name "Karla" :last-name "O'Neil" :age #x1C :sex '\F :occupation "Butcher" :ss# "219308385") 249 (make-instance 'person :first-name "Elizabeth" :last-name "Wilson" :age #x57 :sex '\F :occupation "Butcher" :ss# "249274187") 250 (make-instance 'person :first-name "Elizabeth" :last-name "Riley" :age #x3B :sex '\F :occupation "Doctor" :ss# "489650772") 251 (make-instance 'person :first-name "Irving" :last-name "Kennedy" :age #x46 :sex 'M :occupation "Doctor" :ss# "899583677") 252 (make-instance 'person :first-name "Susan" :last-name "Riley" :age #x2B :sex '\F :occupation "Cashier" :ss# "504945523") 253 (make-instance 'person :first-name "Hillary" :last-name "Wilson" :age #x45 :sex '\F :occupation "Politician" :ss# "437348938") 254 (make-instance 'person :first-name "Joe" :last-name "Riley" :age #x31 :sex 'M :occupation "Politician" :ss# "170903308") 255 (make-instance 'person :first-name "Matthew" :last-name "Riley" :age #x4B :sex 'M :occupation "Advertising" :ss# "773725302"))) 256 257 258 259 260 261 (delete-file "test1.wood") 262 (setq p (create-person-file :filename "test1.wood" :if-exists :supersede)) 263 (loop for person in *people* do (store-person p person)) 264 (wood:close-pheap p) 265 266 267 ;;; (inspect p) 268 ;;; (WOOD::VERIFY-DEBUG-OBJECTS p) 269 270 (setq pp (wood:open-pheap "test1.wood")) 271 (print-people-by-ss# pp *trace-output*) 272 (print-people-by-last-name pp (listener-stream)) 273 (print-people-by-last-name pp *trace-output*) 274 (wood:close-pheap pp) 275 276 |# 277 278 #| 219 279 (defparameter *p* (create-person-file :if-exists :supersede)) 220 280 ; or -
lw-branch/load-wood.lisp
r3 r6 7 7 ;; You may need to edit the definition of the "wood" logical host. 8 8 ;; 9 ;; Portions Copyright © 2006 Clozure Associates 9 10 ;; Copyright © 1996 Digitool, Inc. 10 11 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 22 23 ;; Modification History 23 24 ;; 25 ;; 02/01/06 gz LispWorks port 24 26 ;; 04/11/97 bill compile-and-load checks for "Wrong PFSL version" as well 25 27 ;; as "Wrong FASL version". … … 77 79 ccl::databases-locked-p 78 80 ccl::funcall-with-databases-unlocked 79 ccl::with-databases-unlocked)) 81 ccl::with-databases-unlocked) 82 (:export #:load-wood 83 #:open-pheap #:close-pheap #:with-open-pheap #:root-object #:flush-pheap 84 #:make-shared-buffer #:make-shared-buffer-pool 85 #:pheap #:p-loading-pheap 86 #:p-load #:p-store #:p-stored? #:p-loaded? 87 #:p-make-area #:with-consing-area 88 #:p-cons #:p-list #:p-list-in-area #:p-make-list 89 #:p-make-uvector #:p-make-array #:p-vector 90 #:p-listp #:p-consp #:p-atom #:p-uvectorp #:p-packagep #:p-symbolp 91 #:p-stringp #:p-simple-string-p #:p-vectorp #:p-simple-vector-p #:p-arrayp 92 #:pload-barrier-p 93 #:p-car #:p-cdr #:p-caar #:p-cadr #:p-cdar #:p-cddr 94 #:p-caaar #:p-caadr #:p-cadar #:p-caddr #:p-cdaar #:p-cdadr #:p-cddar 95 #:p-cdddr #:p-caaaar #:p-caaadr #:p-caadar #:p-caaddr #:p-cadaar 96 #:p-cadadr #:p-caddar #:p-cadddr #:p-cdaaar #:p-cdaadr #:p-cdadar 97 #:p-cdaddr #:p-cddaar #:p-cddadr #:p-cdddar #:p-cddddr 98 #:p-nth #:p-nthcdr #:p-last #:p-delq #:p-dolist #:p-assoc 99 #:p-instance-class #:p-slot-value 100 #:p-uvsize #:p-uvref #:p-uvector-subtype-p #:p-svref #:p-%svref #:p-length 101 #:p-aref #:p-array-rank #:p-array-dimensions #:p-array-dimension 102 #:p-intern #:p-find-symbol #:p-find-package #:p-make-package 103 #:p-symbol-name #:p-symbol-package #:p-symbol-value 104 #:p-package-name #:p-package-nicknames 105 #:p-make-btree #:p-btree-p #:p-btree-lookup #:p-btree-store #:p-btree-delete 106 #:p-clear-btree #:p-map-btree #:p-do-btree #:p-btree-count #:p-map-btree-keystrings 107 #:p-make-hash-table #:p-hash-table-p #:p-gethash #:p-remhash #:p-clrhash 108 #:p-hash-table-size #:p-maphash #:p-hash-table-count 109 #:wood-slot-names-vector #:wood-slot-value #:initialize-persistent-instance 110 #:p-make-load-function #:p-make-load-function-object #:p-make-load-function-using-pheap 111 #:p-make-load-function-saving-slots #:progn-load-functions #:progn-init-functions 112 #:p-store-pptr #:opened-pheap 113 #:p-make-pload-barrier #:p-load-through-barrier 114 #:gc-pheap-file #:clear-memory<->disk-tables 115 #:with-egc #:*avoid-cons-caching* 116 #:pptr-p #:pptr #:pptr-pointer #:pptr-pheap 117 #:wood-disk-resident-slot-names #:define-disk-resident-slots 118 #:pheap-pathname #:move-pheap-file 119 #:with-databases-locked #:with-databases-unlocked #:databases-locked-p 120 #:with-transaction #:start-transaction #:commit-transaction #:abort-transaction 121 )) 80 122 81 123 (in-package :wood) 82 124 83 (export '(load-wood 84 open-pheap close-pheap with-open-pheap root-object flush-pheap 85 make-shared-buffer make-shared-buffer-pool 86 pheap p-loading-pheap 87 p-load p-store p-stored? p-loaded? 88 p-make-area with-consing-area 89 p-cons p-list p-list-in-area p-make-list 90 p-make-uvector p-make-array p-vector 91 p-listp p-consp p-atom p-uvectorp p-packagep p-symbolp 92 p-stringp p-simple-string-p p-vectorp p-simple-vector-p p-arrayp 93 pload-barrier-p 94 p-car p-cdr p-caar p-cadr p-cdar p-cddr 95 p-caaar p-caadr p-cadar p-caddr p-cdaar p-cdadr p-cddar p-cdddr 96 p-caaaar p-caaadr p-caadar p-caaddr p-cadaar p-cadadr p-caddar p-cadddr 97 p-cdaaar p-cdaadr p-cdadar p-cdaddr p-cddaar p-cddadr p-cdddar p-cddddr 98 p-nth p-nthcdr p-last p-delq p-dolist p-assoc 99 p-instance-class p-slot-value 100 p-uvsize p-uvref p-uvector-subtype-p p-svref p-%svref p-length p-aref 101 p-array-rank p-array-dimensions p-array-dimension 102 p-intern p-find-symbol p-find-package p-make-package 103 p-symbol-name p-symbol-package p-symbol-value 104 p-package-name p-package-nicknames 105 p-make-btree p-btree-p p-btree-lookup p-btree-store p-btree-delete 106 p-clear-btree p-map-btree p-do-btree p-btree-count p-map-btree-keystrings 107 p-make-hash-table p-hash-table-p p-gethash p-remhash p-clrhash 108 p-hash-table-size p-maphash p-hash-table-count 109 wood-slot-names-vector wood-slot-value initialize-persistent-instance 110 p-make-load-function p-make-load-function-object p-make-load-function-using-pheap 111 p-make-load-function-saving-slots progn-load-functions progn-init-functions 112 p-store-pptr 113 p-make-pload-barrier p-load-through-barrier 114 gc-pheap-file clear-memory<->disk-tables 115 with-egc *avoid-cons-caching* 116 pptr-p pptr pptr-pointer pptr-pheap 117 wood-disk-resident-slot-names define-disk-resident-slots 118 pheap-pathname move-pheap-file 119 with-databases-locked with-databases-unlocked databases-locked-p 120 with-transaction start-transaction commit-transaction abort-transaction 121 )) 125 ; Assume fixnum addresses. 126 ; Comment out this form to compile Wood for files larger than 256 megs (8 Megs in LWW) 127 #-LispWorks4 ;; LWW4 fixnums are tiny. 128 (eval-when (:compile-toplevel :execute :load-toplevel) 129 (pushnew :wood-fixnum-addresses *features*)) 130 131 ;; For simpler conditionalizations 132 #+(and ccl (not ppc-target)) 133 (eval-when (:compile-toplevel :execute :load-toplevel) 134 (pushnew :ccl-68k-target *features*)) 135 136 #| 137 #+LispWorks 138 (eval-when (:compile-toplevel :execute :load-toplevel) 139 ;; For some reason, in lispworks the SYSTEM package has the nickname :CCL, which makes it harder 140 ;; to catch porting errors here. This can be removed once the port is complete. 141 (let ((pkg (find-package "CCL"))) 142 (when pkg 143 (rename-package pkg (package-name pkg) (remove "CCL" (package-nicknames pkg) :test #'equal))))) 144 |# 145 146 147 ;; #+ccl (... #_Foo ...) errs out because #_ is undefined. 148 #+LispWorks 149 (eval-when (:compile-toplevel :execute :load-toplevel) 150 (when (null (get-dispatch-macro-character #\# #\_)) 151 (set-dispatch-macro-character #\# #\_ 152 #'(lambda(s c n) 153 (declare (ignore c n)) 154 (read s nil nil t) 155 nil)))) 122 156 123 157 (setf (logical-pathname-translations "wood") 124 (let ((path (or *load-pathname* *loading-file-source-file*))) 158 (let ((path (or *load-pathname* #+ccl *loading-file-source-file* 159 #+LispWorks dspec:*source-pathname* 160 #+LispWorks system:*current-pathname*))) 125 161 (if path 126 162 (let* ((dest-dir (make-pathname :device (pathname-device path) … … 141 177 '(("wood;**;*.*" "ccl:wood;**;*.*"))))) 142 178 179 (defun fasl-pathname (pathname) 180 (merge-pathnames pathname 181 #+ccl ccl::*.fasl-pathname* 182 #+lispworks (make-pathname :type system:*binary-file-type*))) 183 184 (defvar *debug-wood* nil) 185 143 186 (defun compile-if-needed (file &optional force) 144 187 (let ((lisp (merge-pathnames file ".lisp")) 145 (fasl ( merge-pathnames file ccl::*.fasl-pathname*)))188 (fasl (fasl-pathname file))) 146 189 (when (or force 147 190 (not (probe-file fasl)) 148 191 (> (file-write-date lisp) (file-write-date fasl))) 149 (compile-file lisp :verbose t)))) 192 (compiler:with-optimization-level 193 (if *debug-wood* 194 (compiler::set-optimization-level :safety 3 :debug 3) 195 (compiler::set-optimization-level :speed 3 :safety 0 :debug 0 :float 0)) 196 (compile-file lisp :verbose t))))) 150 197 151 198 (defun compile-and-load (file &optional force-compile) 152 199 (compile-if-needed file force-compile) 153 (handler- case154 (load file :verbose t)155 (simple-error (condition)156 (if (member (simple-condition-format-string condition)157 '("Wrong FASL version." "Wrong PFSL version.")158 :test 'equalp)159 (progn160 (format t "~&;Deleting FASL file from other MCL version...")161 (delete-file (merge-pathnames file ccl::*.fasl-pathname*))162 (compile-and-load file force-compile))163 (error condition)))))200 (handler-bind ((simple-error 201 #'(lambda (condition) 202 (if (member (simple-condition-format-string condition) 203 '("Wrong FASL version." "Wrong PFSL version.") 204 :test 'equalp) 205 (progn 206 (format t "~&;Deleting FASL file from other MCL version...") 207 (delete-file (fasl-pathname file)) 208 (return-from compile-and-load (compile-and-load file force-compile))) 209 (error condition))))) 210 (load file :verbose t))) 164 211 165 212 (defparameter *wood-files* 166 '("block-io-mcl" "split-lfun" "q" 213 '("compat" 214 #+ccl "block-io-mcl" #+ccl "split-lfun" 215 "q" 167 216 "disk-page-hash" "disk-cache" "woodequ" "disk-cache-accessors" 168 "disk-cache-inspector" "persistent-heap" "version-control" 217 #+ccl "disk-cache-inspector" #+LispWorks "lw-inspector" 218 "persistent-heap" "version-control" 169 219 "btrees" "persistent-clos" 170 "recovery" "wood-gc")) 220 ;; Not ported yet 221 #-LispWorks "recovery" #-LispWorks "wood-gc")) 171 222 172 223 (defun load-wood (&optional force-compile) 173 224 (with-compilation-unit () 174 225 (compile-if-needed "wood:wood;load-wood") 175 (unless (boundp 'ccl::*elements-per-buffer*)176 (compile-and-load "wood:patches;big-io-buffer-patch"))226 #-lispworks (unless (boundp 'ccl::*elements-per-buffer*) 227 (compile-and-load "wood:patches;big-io-buffer-patch")) 177 228 (dolist (file *wood-files*) 178 229 (compile-and-load (merge-pathnames file "wood:wood;") force-compile)) -
lw-branch/persistent-clos.lisp
r3 r6 6 6 ;; Support for saving/restoring CLOS instances to/from Wood persistent heaps. 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 21 22 ;; Modification History 22 23 ;; 24 ;; 02/01/06 gz LispWorks port 23 25 ;; 08/28/98 akh add dc-shared-initialize - fixes case of change class in memory, then write a slot-value to pheap 24 26 ;; left us with the class updated on disk but not the instance-slots with initforms … … 156 158 157 159 160 #+LispWorks 161 (defparameter $wrapper-names-index 162 (or (loop with wrapper = (progn 163 (make-instance 'simple-error) 164 (clos::class-wrapper (find-class 'simple-error))) 165 for i in '(0 1 2 -1 -2 -3) 166 as val = (%svref wrapper i) 167 when (and (consp val) 168 (consp (cdr val)) 169 (null (cddr val)) 170 (equal val '(conditions::format-string conditions::format-arguments))) 171 return i) 172 (error "Couldn't find wrapper names index"))) 173 174 175 176 177 ;; In lispworks, the names are in a list not a vector, but seems to work ok. 178 (defun-inline %wrapper-instance-slots (wrapper) 179 #+ccl (ccl::%wrapper-instance-slots wrapper) 180 #-ccl (%svref wrapper $wrapper-names-index)) 181 182 #+LispWorks 183 (defun class-own-wrapper (class) 184 (clos::class-wrapper class)) 185 158 186 ; This knows internals of MCL's CLOS implementation 159 187 (defun class-slots-vector (class) 160 (ccl::%wrapper-instance-slots 161 (or (ccl::%class-own-wrapper class) 162 (ccl::initialize-class-and-wrapper class)))) 188 (%wrapper-instance-slots #+ccl (or (ccl::%class-own-wrapper class) 189 (ccl::initialize-class-and-wrapper class)) 190 #+LispWorks (clos::class-wrapper class))) 191 163 192 164 193 (defun dc-make-class-slots-vector (disk-cache class &optional … … 166 195 (%p-store pheap (wood-slot-names-vector (class-prototype class)))) 167 196 168 (def-predicate c cl::classp (p disk-cache pointer)197 (def-predicate classp (p disk-cache pointer) 169 198 (dc-vector-subtype-p disk-cache pointer $v_class)) 170 199 … … 203 232 (setq wrapper (class-own-wrapper class)) 204 233 (unless wrapper (error "Can't find class-own-wrapper for ~s" class))) 205 ( ccl::%wrapper-instance-slots wrapper)))234 (%wrapper-instance-slots wrapper))) 206 235 207 236 (defun p-instance-class (instance) … … 279 308 res)) 280 309 281 (def-predicate ccl::standard-instance-p (p disk-cache pointer) 282 (dc-vector-subtype-p disk-cache pointer $v_instance)) 283 284 (def-accessor ccl::instance-class-wrapper (p) (disk-cache pointer) 310 (def-accessor instance-class-wrapper (p) (disk-cache pointer) 285 311 (require-satisfies dc-standard-instance-p disk-cache pointer) 286 312 (dc-%svref disk-cache pointer $instance.wrapper)) … … 329 355 (defun dc-updated-instance-slots (disk-cache instance memory-class pheap &optional 330 356 dont-update) 357 ;(assert (dc-vector-subtype-p disk-cache instance $v_instance)) 331 358 (with-databases-locked 332 359 (let ((old-wrapper (dc-%svref disk-cache instance $instance.wrapper)) … … 401 428 402 429 430 ;;; *** TODO: Need Lispworks version. 431 #+CCL 403 432 (defun dc-shared-initialize (disk-cache pheap slot-values new-instance-slots class &optional (slot-names t)) 404 433 ;; I don't know how to find all this stuff in the disk version - I don't think it's there. … … 422 451 423 452 424 (def-predicate ccl::standard-instance-p (p disk-cache pointer)453 (def-predicate standard-instance-p (p disk-cache pointer) 425 454 (and (dc-uvectorp disk-cache pointer) 426 ( eq (dc-%vector-subtype disk-cache pointer)$v_instance)))455 (dc-vector-subtype-p disk-cache pointer $v_instance))) 427 456 428 457 (def-accessor slot-value (p slot-name) (disk-cache pointer) … … 516 545 pointer)) 517 546 547 #+CCL 518 548 (defmethod %p-store-object (pheap (object ccl::funcallable-standard-object) descend) 519 549 (declare (ignore pheap descend)) … … 536 566 (dc-updated-instance-slots disk-cache address class pheap) 537 567 (dotimes (i (length slot-names)) 538 (let ((slot-name ( svrefslot-names i)))568 (let ((slot-name (elt slot-names i))) 539 569 (multiple-value-bind (value imm?) 540 570 (if (slot-boundp object slot-name) … … 547 577 ; and do something else as well. 548 578 549 (defmacro sd-slots (sd)550 `(ccl::%svref ,sd 1))551 552 579 (defmethod instance-slot-names ((instance structure-object)) 553 (let ((sd (gethash (car (ccl::%svref instance 0)) ccl::%defstructs%)) 580 #+ccl 581 (let ((sd (gethash (car (%svref instance 0)) ccl::%defstructs%)) 554 582 (res nil)) 555 (dolist (slot ( sd-slots sd))583 (dolist (slot (%svref sd 1)) ;; sd-slots 556 584 (let ((name (car slot))) 557 585 (when (symbolp name) 558 586 (push name res)))) 559 (nreverse res))) 587 (nreverse res)) 588 #+LispWorks 589 (structure:structure-class-slot-names (class-of instance))) 560 590 561 591 (defmethod instance-slot-names ((instance standard-object)) … … 573 603 (if (slot-boundp object slot) 574 604 (slot-value object slot) 575 ( ccl::%unbound-marker-8))))605 (%unbound-marker)))) 576 606 (slot-values (mapcar mapper slot-names))) 577 607 (declare (dynamic-extent mapper)) 578 608 (values `(allocate-instance-of-class ,(class-name (class-of object))) 579 609 (when slot-names 580 `( ccl::%set-slot-values,slot-names ,slot-values)))))610 `(%set-slot-values ,object ,slot-names ,slot-values))))) 581 611 582 612 (defun allocate-instance-of-class (class-name) … … 624 654 disk-cache pointer class pheap t) 625 655 (dotimes (i (length slot-names)) 626 (let ((slot-name ( svrefslot-names i)))656 (let ((slot-name (elt slot-names i))) 627 657 (when (or (null real-slot-names) (position slot-name real-slot-names)) 628 658 (multiple-value-bind (pointer immediate?) … … 648 678 instance)) 649 679 680 650 681 ; These methods allow users to specialize the way that CLOS instances are saved. 651 682 … … 716 747 (mapc #'require-symbol accessors)) 717 748 (when class 718 (let* ((class-slots (mapcar 'slot-definition-name (c cl:class-instance-slots class))))749 (let* ((class-slots (mapcar 'slot-definition-name (class-instance-slots class)))) 719 750 (flet ((require-slot (slot) 720 751 (unless (member slot class-slots :test 'eq) … … 738 769 ',slots) 739 770 (record-source-file ',class-name :disk-resident-slots) 740 ',class-name))) 771 ',class-name))) 741 772 742 773 -
lw-branch/persistent-heap.lisp
r3 r6 6 6 ;; Code to maintain a Lisp heap in a file. 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 21 22 ;; Modification History 22 23 ;; 24 ;; 02/01/06 gz LispWorks port 23 25 ;; 11/02/97 akh bill's dc-aref-vector-and-index 24 26 ;; 10/28/97 akh bill's patches for multi-dim array and always rehash … … 188 190 ;; 3) Don't worry about being able to walk memory. 189 191 190 (defpackage :wood)191 192 (in-package :wood) 192 193 193 194 (export '(create-pheap open-pheap close-pheap with-open-pheap 194 195 root-object p-load p-store 196 close-all-pheaps 195 197 )) 196 198 197 199 (eval-when (:compile-toplevel :execute) 198 200 (require :woodequ) 199 (require :lispequ))201 #+ccl (require :lispequ)) 200 202 201 203 ; Dispatch tables at end of file 202 204 (declaim (special *p-load-subtype-functions* 203 205 *subtype->bytes-per-element* 206 #+LispWorks *subtype->array-byte-offset* 204 207 *p-store-subtype-functions* 205 208 *subtype->uvreffer* 206 209 *subtype->uvsetter* 207 *subtype-initial-element*)) 210 *subtype-initial-element* 211 #+LispWorks *subtype->array-element-type*)) 208 212 209 213 (defparameter *pheap<->mem-hash-table-size* 500) … … 213 217 (consing-area :accessor pheap-consing-area :initarg :consing-area) 214 218 (pptr-hash :reader pptr-hash 215 :initform (make-hash -table:weak :value :test 'eql))219 :initform (make-hash :weak :value :test 'eql)) 216 220 (wrapper-hash :reader wrapper-hash 217 :initform (make-hash -table:weak :key :test 'eq))221 :initform (make-hash :weak :key :test 'eq)) 218 222 (pheap->mem-hash :reader pheap->mem-hash 219 :initform (make-hash -table:weak :value220 221 223 :initform (make-hash :weak :value 224 :test 'eql 225 :size *pheap<->mem-hash-table-size*)) 222 226 (mem->pheap-hash :reader mem->pheap-hash 223 :initform (make-hash -table:weak :key224 225 227 :initform (make-hash :weak :key 228 :test 'eq 229 :size *pheap<->mem-hash-table-size*)) 226 230 (p-load-hash :reader p-load-hash 227 :initform (make-hash -table:weak :key :test 'eq))231 :initform (make-hash :weak :key :test 'eq)) 228 232 (inside-p-load :accessor inside-p-load :initform nil) 229 233 (p-store-hash :reader p-store-hash 230 :initform (make-hash -table:weak :key :test 'eq))234 :initform (make-hash :weak :key :test 'eq)) 231 235 (inside-p-store :accessor inside-p-store :initform nil))) 232 236 … … 258 262 (write-string "#.(" stream) 259 263 (prin1 'pptr stream) 260 (tyo #\space stream) 261 (prin1 (pptr-pheap pptr) stream) 264 (write-char #\space stream) 265 ;; (prin1 (pptr-pheap pptr) stream) 266 (prin1 (pathname-name (pheap-stream (pptr-pheap pptr))) stream) 262 267 (write-string " #x" stream) 263 268 (let ((*print-base* 16)) 264 269 (prin1 (pptr-pointer pptr) stream)) 265 ( tyo#\) stream))270 (write-char #\) stream)) 266 271 267 272 (defun pptr (pheap pointer) … … 293 298 (defparameter *default-area-segment-size* 4096) 294 299 295 ;;;;;;;;;;;;;;;;;;;;;;;296 ;;;297 ;;; WITH-EGC macro can disable EGC while dumping or loading.298 ;;; This prevents extraneous rehashing of the mem->pheap hash table299 ;;;300 301 (defmacro with-egc (state &body body)302 (let ((egc-state (gensym)))303 `(let ((,egc-state (ccl:egc-enabled-p)))304 (unwind-protect305 (progn306 (ccl:egc ,state)307 ,@body)308 (ccl:egc ,egc-state)))))309 300 ;;;;;;;;;;;;;;;;;;;;;;;;;; 310 301 ;; … … 330 321 (area-segment-size *default-area-segment-size*) 331 322 (page-size *default-page-size*) 332 (mac-file-creator :ccl2)333 (external-format :WOOD))323 #+ccl (mac-file-creator :ccl2) 324 #+ccl (external-format :WOOD)) 334 325 (let ((min-page-size 512)) 335 326 (setq page-size … … 341 332 :if-does-not-exist :create 342 333 :page-size page-size 343 :mac-file-creatormac-file-creator344 :external-formatexternal-format)))334 #+ccl :mac-file-creator #+ccl mac-file-creator 335 #+ccl :external-format #+ccl external-format))) 345 336 (fill-long disk-cache 0 0 (ash (disk-cache-page-size disk-cache) -2)) 346 337 (initialize-vector-storage … … 354 345 ($pheap.page-size t) page-size) 355 346 (setf (read-string disk-cache 356 (+ $root-vector (- $t_vector) (ash $pheap-header-size 2))) 347 (+ $root-vector (- $t_vector) (ash $pheap-header-size 2)) 348 nil) 357 349 #.(format nil "~%This is a persistent heap~%~ 358 created by William's Object Oriented Database~%~359 in Macintosh Common Lisp.~%"))350 created by William's Object Oriented Database~%~ 351 in Macintosh Common Lisp.~%")) 360 352 (close-disk-cache disk-cache) 361 353 filename)) 362 354 363 355 (defvar *open-pheaps* nil) 356 357 (defun opened-pheap (path) 358 (let ((real-path (probe-file path))) 359 (and real-path 360 (dolist (p *open-pheaps*) 361 (when (equalp real-path (pheap-pathname p)) 362 (return p)))))) 363 364 365 (defun close-all-pheaps () 366 (loop while *open-pheaps* 367 do (close-pheap (car *open-pheaps*)))) 364 368 365 369 (defparameter *open-pheap-keywords* … … 373 377 :shared-buffer 374 378 :shared-buffer-pool 375 :mac-file-creator376 :external-format379 #+ccl :mac-file-creator 380 #+ccl :external-format 377 381 :pheap-class 378 382 :initial-transaction-p)) … … 389 393 shared-buffer 390 394 shared-buffer-pool 391 (mac-file-creator :ccl2)392 (external-format :WOOD)395 #+ccl (mac-file-creator :ccl2) 396 #+ccl (external-format :WOOD) 393 397 (pheap-class (load-time-value (find-class 'pheap))) 394 398 (initial-transaction-p t) … … 412 416 :shared-buffer-pool shared-buffer-pool 413 417 :write-hook 'pheap-write-hook 414 :mac-file-creatormac-file-creator415 :external-formatexternal-format418 #+ccl :mac-file-creator #+ccl mac-file-creator 419 #+ccl :external-format #+ccl external-format 416 420 :initial-transaction-p initial-transaction-p)))) 417 421 (when (null disk-cache) … … 423 427 :area-segment-size area-segment-size 424 428 :page-size page-size 425 :mac-file-creatormac-file-creator426 :external-formatexternal-format)429 #+ccl :mac-file-creator #+ccl mac-file-creator 430 #+ccl :external-format #+ccl external-format) 427 431 (return-from open-pheap 428 432 (apply #'open-pheap filename :if-exists :overwrite rest))) … … 481 485 (page-size (dc-%svref disk-cache $root-vector $pheap.page-size)) 482 486 (shared-buffer (disk-cache-shared-buffer disk-cache)) 483 (mac-file-creator (mac-file-creator old-filename))484 (external-format (mac-file-type old-filename)))487 #+ccl (mac-file-creator (mac-file-creator old-filename)) 488 #+ccl (external-format (mac-file-type old-filename))) 485 489 (flet ((open-it (pathname) 486 490 (setf (pheap-disk-cache pheap) … … 490 494 :shared-buffer shared-buffer 491 495 :write-hook 'pheap-write-hook 492 :mac-file-creatormac-file-creator493 :external-formatexternal-format))496 #+ccl :mac-file-creator #+ccl mac-file-creator 497 #+ccl :external-format #+ccl external-format)) 494 498 (push pheap *open-pheaps*))) 495 499 (declare (dynamic-extent #'open-it)) … … 568 572 (setq *open-disk-caches* 569 573 (delq (pheap-disk-cache pheap) *open-disk-caches*)) 570 (setq ccl::*open-file-streams* 571 (delq (pheap-stream pheap) ccl::*open-file-streams*))))))) 572 573 (pushnew 'flush-all-open-pheaps *lisp-cleanup-functions*) 574 #+ccl(setq ccl::*open-file-streams* 575 (delq (pheap-stream pheap) ccl::*open-file-streams*)) 576 #-ccl(ignore-errors (close (pheap-stream pheap) :abort t))))))) 577 578 (register-lisp-cleanup-function 'flush-all-open-pheaps) 574 579 575 580 (defmacro with-transaction ((pheap) &body body) … … 627 632 (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook))))) 628 633 629 (defun dc-page-write-count (disk-cache) 634 (defun dc-page-write-count (disk-cache #+LispWorks &optional #+LispWorks ignore) 635 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 630 636 (dc-%svref disk-cache $root-vector $pheap.page-write-count)) 631 637 … … 682 688 (pptr pheap pointer)))) 683 689 684 (defun dc-root-object (disk-cache) 685 (dc-%svref disk-cache $root-vector $pheap.root)) 690 (defun dc-root-object (disk-cache #+LispWorks &optional #+LispWorks ignore) 691 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 692 (dc-%svref disk-cache $root-vector $pheap.root)) 686 693 687 694 (defvar *loading-pheap* nil) … … 717 724 (declare (fixnum tag)) 718 725 (let ((f (locally (declare (optimize (speed 3) (safety 0))) 719 (svref #(p-load-immediate ; $t_fixnum 720 p-load-vector ; $t_vector 721 p-load-symbol ; $t_symbol 722 p-load-dfloat ; $t_dfloat 723 p-load-cons ; $t_cons 724 p-load-immediate ; $t_sfloat 725 p-load-lfun ; $t_lfun 726 p-load-immediate) ; $t_imm 726 (svref #+ccl (tag-vector :fixnum p-load-immediate ; $t_fixnum 727 :vector p-load-vector ; $t_vector 728 :symbol p-load-symbol ; $t_symbol 729 :dfloat p-load-dfloat ; $t_dfloat 730 :cons p-load-cons ; $t_cons 731 :sfloat p-load-immediate ; $t_sfloat 732 :lfun p-load-lfun ; $t_lfun 733 :imm p-load-immediate) ; $t_imm 734 #+LispWorks (tag-vector :pos-fixnum p-load-immediate 735 :neg-fixnum p-load-immediate 736 :vector p-load-vector 737 :symbol p-load-symbol 738 :dfloat p-load-dfloat 739 :cons p-load-cons 740 :char p-load-immediate 741 :imm p-load-immediate) 727 742 tag)))) 728 743 (unless (or (eq depth t) (eq f 'p-load-immediate)) … … 835 850 ) ; end of #+ppc-target progn 836 851 852 (defun uvector-subtype (object) 853 #+ccl `(and (ccl::uvectorp object) (ccl->wood-subtype (ccl::%vect-subtype object))) 854 #-ccl 855 (and (arrayp object) 856 (let ((type (array-element-type object))) 857 (cond ((eq type 'base-char) $v_sstr) 858 ((eq type 'simple-char) $v_xstr) 859 ((eq type 'double-float) $v_floatv) 860 ((eq type 't) $v_genv) 861 (t (case (and (consp type) (car type)) 862 (unsigned-byte 863 (let ((size (cadr type))) 864 (cond ((eql size 8) $v_ubytev) 865 ((eql size 16) $v_uwordv) 866 ((eql size 32) $v_ulongv) 867 ((eql size 1) $v_bitv)))) 868 (signed-byte 869 (let ((size (cadr type))) 870 (cond ((eql size 8) $v_sbytev) 871 ((eql size 16) $v_swordv) 872 ((eql size 32) $v_slongv)))))))))) 873 874 (defun-inline make-typed-ivector (length wood-subtype) 875 #+ccl (ccl::make-uvector length (wood->ccl-subtype wood-subtype)) 876 ;; TODO: make a table, better yet, make a p-load-xxx-vector for each one? 877 #-ccl 878 (cond ((eq wood-subtype $v_ubytev) (make-array length :element-type '(unsigned-byte 8))) 879 ((eq wood-subtype $v_uwordv) (make-array length :element-type '(unsigned-byte 16))) 880 ((eq wood-subtype $v_ulongv) (make-array length :element-type '(unsigned-byte 32))) 881 ((eq wood-subtype $v_floatv) (make-array length :element-type 'double-float)) 882 ((eq wood-subtype $v_sbytev) (make-array length :element-type '(signed-byte 8))) 883 ((eq wood-subtype $v_swordv) (make-array length :element-type '(signed-byte 16))) 884 ((eq wood-subtype $v_slongv) (make-array length :element-type '(signed-byte 32))) 885 ((eq wood-subtype $v_sstr) (make-string length :element-type 'base-char)) 886 ((eq wood-subtype $v_xstr) (make-string length :element-type 'simple-char)))) 887 888 889 (defun-inline uvectorp (object) 890 #+ccl (ccl::uvectorp object) 891 #-ccl (and (uvector-subtype object) t)) 892 893 (defun-inline %vect-subtype (vect) 894 #+ccl (ccl::%vect-subtype vect) 895 #-ccl (error "vect-subtype not implemented: ~s" vect)) 896 837 897 838 898 (defstruct uninitialize-structure) … … 840 900 (defvar *uninitialized-structure* 841 901 (make-uninitialize-structure)) 902 903 (defun-inline make-typed-gvector (length wood-subtype) 904 #+ccl (ccl::make-uvector length (wood->ccl-subtype wood-subtype)) 905 #-ccl (ecase wood-subtype 906 (#.$v_genv (make-array length)))) 842 907 843 908 ; general vector 844 909 (defun p-load-gvector (pheap disk-cache pointer depth subtype &optional 845 910 special-index-p special-index-value struct-p) 911 #-ccl (assert (and (eql subtype $v_genv) (not special-index-p) (not struct-p))) 846 912 (let* (length 847 913 modified? … … 853 919 (and (fixnump depth) (< depth length))) 854 920 (return-from p-load-gvector (pptr pheap pointer)) 855 (let ((res (ccl::make-uvector 856 length (wood->ccl-subtype subtype)))) 921 (let ((res (make-typed-gvector length subtype))) 857 922 (when struct-p 858 923 ; Make sure it looks like a structure … … 882 947 (values vector modified?))) 883 948 949 #+ccl 884 950 (defun p-load-header (pheap disk-cache pointer depth subtype &optional 885 951 special-index-p special-index-value) … … 893 959 special-index-p special-index-value)))) 894 960 895 # -ppc-target961 #+ccl-68k-target 896 962 (defun p-load-arrayh (pheap disk-cache pointer depth subtype) 897 963 (p-load-header pheap disk-cache pointer depth subtype)) … … 942 1008 943 1009 1010 #+LispWorks 1011 (defun p-load-arrayh (pheap disk-cache pointer depth subtype) 1012 (let* ((cached? t) 1013 (bits (dc-%arrayh-bits disk-cache pointer)) 1014 (fillp (logbitp $arh_fill_bit bits)) 1015 (adjustablep (logbitp $arh_adjp_bit bits)) 1016 (displacedp (logbitp $arh_disp_bit bits)) 1017 (subtag (dc-%arrayh-type disk-cache pointer)) 1018 (etype (if (eql subtag $v_badptr) 1019 (dc-%svref-value pheap disk-cache pointer $arh.etype) 1020 (svref *subtype->array-element-type* subtag))) 1021 (rank (dc-array-rank disk-cache pointer)) 1022 (dims (if (eql rank 1) 1023 (dc-%svref-fixnum disk-cache pointer $arh.vlen '$arh.vlen) 1024 (loop for i from 0 below rank 1025 collect (dc-%svref-fixnum disk-cache pointer (+ $arh.fill i))))) 1026 (array (maybe-cached-value pheap pointer 1027 (setq cached? nil) 1028 (if displacedp 1029 (make-array 0 :displaced-to #() 1030 :adjustable adjustablep :fill-pointer fillp 1031 :element-type etype) 1032 (make-array dims 1033 :adjustable adjustablep :fill-pointer fillp 1034 :element-type etype))))) 1035 (when cached? 1036 (unless (and (equal (array-element-type array) etype) 1037 (eq displacedp (and (displaced-array-p array) t)) 1038 (eq adjustablep (and (adjustable-array-p array) t)) 1039 (eq fillp (and (array-has-fill-pointer-p array) t))) 1040 (error "Incompatible array ~s" array))) 1041 (when (or (not cached?) 1042 (and (eq depth t) 1043 (let ((p-load-hash (p-load-hash pheap))) 1044 (unless (gethash array p-load-hash) 1045 (setf (gethash array p-load-hash) array))))) 1046 (ecase subtype 1047 (#.$v_arrayh 1048 (let* ((displaced-to (pointer-load pheap (dc-%svref disk-cache pointer $arh.vect) 1049 depth disk-cache)) 1050 (displaced-offset (dc-%svref-fixnum disk-cache pointer $arh.offs '$arh.offs)) 1051 (adjusted-array (adjust-array array dims 1052 :displaced-to displaced-to 1053 :displaced-index-offset displaced-offset))) 1054 (unless (eq adjusted-array array) 1055 (error "Couldn't readjust array ~s" array)))) 1056 (#.$v_garrayh 1057 (let* ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil) 1058 ((listp depth) (car depth)) 1059 (t depth))) 1060 ($arh.data (%arrayh-overhead array)) 1061 (total-size (array-total-size array))) 1062 (dotimes (i total-size) 1063 (setf (row-major-aref array i) 1064 (multiple-value-bind (value imm?) 1065 (dc-%svref disk-cache pointer (+ $arh.data i)) 1066 (if imm? 1067 value 1068 (pointer-load pheap value next-level-depth disk-cache))))))) 1069 (#.$v_iarrayh 1070 (let* ((overhead-bytes (* 4 (%arrayh-overhead array))) 1071 (num-bytes (dc-%vector-size disk-cache pointer))) 1072 (load-bytes-to-iarray disk-cache 1073 (addr+ disk-cache pointer (- overhead-bytes $t_vector)) 1074 (- num-bytes overhead-bytes) 1075 array)))) 1076 (when fillp 1077 (setf (fill-pointer array) (dc-%svref-fixnum disk-cache pointer $arh.fill '$arh.fill)))) 1078 array)) 1079 1080 #+ccl 944 1081 (defun p-load-istruct (pheap disk-cache pointer depth subtype) 945 1082 (when (or (eq depth :single) (fixnump depth)) … … 951 1088 vector)) 952 1089 1090 #+ccl 953 1091 (defun p-load-struct (pheap disk-cache pointer depth subtype) 954 1092 (let ((vector (p-load-gvector pheap disk-cache pointer depth subtype nil nil t))) … … 958 1096 (setf (uvref vector 0) (p-load struct-type))))) 959 1097 vector)) 1098 1099 #+LispWorks 1100 (defun p-store-struct (pheap object descend disk-cache address length) 1101 (assert (eql length (uvsize object))) 1102 (dotimes (i length) 1103 (let ((value (if (eql i 0) (class-of object) (%%svref object i)))) 1104 (multiple-value-bind (element imm?) (%p-store pheap value descend) 1105 (setf (dc-%svref disk-cache address i imm?) element))))) 1106 1107 #+LispWorks 1108 (defun p-load-struct (pheap disk-cache pointer depth subtype) 1109 (declare (ignore subtype)) 1110 (let* (modified? 1111 (cached? t) 1112 (struct (maybe-cached-value pheap pointer 1113 (when (or (null depth) 1114 (and (fixnump depth) 1115 (< depth (dc-%simple-vector-length disk-cache pointer)))) 1116 (return-from p-load-struct (pptr pheap pointer))) 1117 (setq cached? nil) 1118 (let* ((class (multiple-value-bind (cpointer imm?) 1119 (dc-%svref disk-cache pointer 0) 1120 (and (not imm?) (pointer-load pheap cpointer :default disk-cache)))) 1121 (res (allocate-instance class))) 1122 res)))) 1123 (when (or (not cached?) 1124 (listp depth) 1125 (and (eq depth t) 1126 (let ((p-load-hash (p-load-hash pheap))) 1127 (unless (gethash struct p-load-hash) 1128 (setf (gethash struct p-load-hash) struct))))) 1129 (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil) 1130 ((listp depth) (car depth)) 1131 (t depth)))) 1132 (setq modified? t) 1133 (loop for i from 1 below (min (uvsize struct) (dc-%simple-vector-length disk-cache pointer)) 1134 do (setf (uvref struct i) 1135 (multiple-value-bind (pointer immediate?) 1136 (dc-%svref disk-cache pointer i) 1137 (if immediate? 1138 pointer 1139 (pointer-load pheap pointer next-level-depth disk-cache))))))) 1140 (values struct modified?))) 1141 1142 960 1143 961 1144 ; ivectors … … 969 1152 (if (and depth 970 1153 (or (not (fixnump depth)) (<= length depth))) 971 (load-byte -array1154 (load-bytes-to-ivector 972 1155 disk-cache (addr+ disk-cache pointer $v_data) size 973 (ccl::make-uvector length (wood->ccl-subtype subtype)) 974 0 t) 1156 (make-typed-ivector length subtype)) 975 1157 (return-from p-load-ivector (pptr pheap pointer))))))) 976 1158 (when (and cached? (eq depth t)) … … 979 1161 (unless (eql (uvsize res) (dc-uvsize disk-cache pointer)) 980 1162 (error "Inconsistency. Disk ivector is different size than in-memory version.")) 981 (unless (eql (wood->ccl-subtype subtype) 982 (ccl::%vect-subtype res)) 1163 (unless (eql subtype (uvector-subtype res)) 983 1164 (error "Inconsistency. Subtype mismatch.")) 984 (load-byte -array disk-cache (addr+ disk-cache pointer $v_data) size res 0 t)))1165 (load-bytes-to-ivector disk-cache (addr+ disk-cache pointer $v_data) size res))) 985 1166 res)) 986 1167 987 # -ppc-target1168 #+ccl-68k-target 988 1169 (defun p-load-bignum (pheap disk-cache pointer depth subtype) 989 1170 (p-load-ivector pheap disk-cache pointer depth subtype)) … … 994 1175 ;; other words are the magnitude. 995 1176 ;; Some day, recode this using bignum internals so that it doesn't cons so much. 996 # +ppc-target1177 #-ccl-68k-target 997 1178 (defun p-load-bignum (pheap disk-cache pointer depth subtype) 998 1179 (declare (ignore pheap depth subtype)) … … 1010 1191 value))))) 1011 1192 1012 # +ppc-target1193 #-ccl-68k-target 1013 1194 (defun p-load-bit-vector (pheap disk-cache pointer depth subtype) 1014 (declare ( fixnumsubtype))1195 (declare (ignore subtype)) 1015 1196 (let* ((cached? t) 1016 1197 (res (maybe-cached-value pheap pointer 1017 1198 (setq cached? nil) 1018 (let ((length (dc-uvsize disk-cache pointer)) 1019 (size (dc-%vector-size disk-cache pointer))) 1020 (declare (fixnum size))1021 (load-byte -array1199 (let ((length (dc-uvsize disk-cache pointer)) ; length in bits 1200 (size (dc-%vector-size disk-cache pointer))) ; size in bytes 1201 #-LispWorks(declare (fixnum size)) 1202 (load-bytes-to-bit-vector 1022 1203 disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) 1023 (ccl::make-uvector length (wood->ccl-subtype subtype))1024 0 t)))))1204 #-ccl (make-array length :element-type 'bit) 1205 #+ccl (ccl::make-uvector length (wood->ccl-subtype subtype))))))) 1025 1206 (when (and cached? (eq depth t)) 1026 1207 (let* ((size (dc-%vector-size disk-cache pointer)) 1027 1208 (subtype (dc-%vector-subtype disk-cache pointer))) 1028 (declare (fixnum size))1209 #-LispWorks(declare (fixnum size)) 1029 1210 (unless (eql (uvsize res) (dc-uvsize disk-cache pointer)) 1030 1211 (error "Inconsistency. Disk ivector is different size than in-memory version.")) 1031 (unless (eql (wood->ccl-subtype subtype) 1032 (ccl::%vect-subtype res)) 1212 (unless (eql subtype (uvector-subtype res)) 1033 1213 (error "Inconsistency. Subtype mismatch.")) 1034 (load-byte -array disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) res 0 t)))1214 (load-bytes-to-bit-vector disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) res))) 1035 1215 res)) 1036 1216 … … 1072 1252 1073 1253 (defun p-load-cons (pheap disk-cache pointer depth) 1074 1254 (p-load-cons-internal pheap disk-cache pointer depth nil nil)) 1075 1255 1076 1256 (defvar *avoid-cons-caching* nil) … … 1122 1302 ; All this hair is to create the lfun before loading its immediates. 1123 1303 ; This allows circular references. 1304 #+ccl 1124 1305 (defun p-load-lfun (pheap disk-cache pointer depth) 1125 1306 (let (imms imms-address indices … … 1149 1330 (when imms 1150 1331 (dotimes (i imms-length) 1151 (multiple-value-bind (val imm?) (dc-%svref disk-cache imms-address i) 1152 (setf (ccl::%svref imms i) 1153 (if imm? val (pointer-load-internal pheap val :default disk-cache))))) 1332 (setf (ccl::%svref imms i) (dc-%svref-value pheap disk-cache imms-address i))) 1154 1333 (ccl::%patch-lfun-immediates lfun imms indices)) 1155 1334 lfun))) … … 1275 1454 1276 1455 #+ppc-target 1277 (progn 1278 1279 (declaim (inline %ccl2-fixnum-p)) 1280 1281 (defun %ccl2-fixnum-p (ppc-fixnum) 1456 (defun-inline %ccl2-fixnum-p (ppc-fixnum) 1282 1457 (declare (fixnum ppc-fixnum)) 1283 1458 (and (>= ppc-fixnum (- (ash 1 28))) (< ppc-fixnum (ash 1 28)))) 1284 1459 1285 ) 1286 1287 (declaim (inline immediate-object-p)) 1288 1289 (defun immediate-object-p (object) 1290 #-ppc-target 1460 1461 (defun-inline immediate-object-p (object) 1462 #+ccl-68k-target 1291 1463 (ccl::dtagp object (+ (ash 1 ccl::$t_fixnum) 1292 1464 (ash 1 ccl::$t_sfloat) … … 1296 1468 (if (eql typecode ppc::tag-fixnum) 1297 1469 (%ccl2-fixnum-p object) 1298 (eql typecode ppc::tag-imm)))) 1470 (eql typecode ppc::tag-imm))) 1471 #+LispWorks ;; see %%store-pointer 1472 (or (fixnump object) 1473 (characterp object) 1474 (eq object (%unbound-marker)))) 1299 1475 1300 1476 ; Same comment here as for pointer-load: … … 1332 1508 &body body 1333 1509 &environment env) 1334 (multiple-value-bind (body decls) ( ccl::parse-body body env)1510 (multiple-value-bind (body decls) (parse-body body env) 1335 1511 (unless (null (cddr body)) 1336 1512 (error "body must be of the form (conser filler)")) … … 1340 1516 (filler-var (gensym))) 1341 1517 `(let ((,conser-var #'(lambda (,disk-cache ,object) 1342 (declare (ignor e-if-unused,object))1518 (declare (ignorable ,object)) 1343 1519 ,@decls 1344 1520 ,conser)) 1345 1521 (,filler-var #'(lambda (,pheap ,disk-cache ,object ,address ,descend) 1346 (declare (ignor e-if-unused,pheap ,descend))1522 (declare (ignorable ,pheap ,descend)) 1347 1523 ,@decls 1348 1524 ,filler))) … … 1385 1561 &body body 1386 1562 &environment env) 1387 (multiple-value-bind (body decls) ( ccl::parse-body body env)1563 (multiple-value-bind (body decls) (parse-body body env) 1388 1564 (destructuring-bind (conser filler) body 1389 1565 (let ((conser-var (gensym)) … … 1490 1666 (defvar *preserve-lfun-info* nil) 1491 1667 1668 #+ccl 1492 1669 (defmethod %p-store-object (pheap (object function) descend) 1493 1670 (let* ((split-vec (apply #'vector (split-lfun object *preserve-lfun-info*))) … … 1514 1691 (let* ((inner-cached? t)) 1515 1692 (setq address (%p-store-object-body (pheap cdr descend disk-cache address) 1516 (declare (ignor e-if-unusedcdr disk-cache address))1693 (declare (ignorable cdr disk-cache address)) 1517 1694 (dc-cons disk-cache $pheap-nil $pheap-nil) 1518 1695 (setq inner-cached? nil)) 1519 cached? inner-cached?)) 1696 cached? inner-cached?)) 1520 1697 (setf (dc-cdr disk-cache outer-address) address) 1521 1698 (unless cached? … … 1542 1719 1543 1720 (defun dc-cons-float (disk-cache value &optional area) 1544 (setq value (require-type value ' float))1721 (setq value (require-type value 'double-float)) 1545 1722 (let ((address (%allocate-storage disk-cache area 8))) 1546 1723 (setf (read-double-float disk-cache (decf address $t_cons)) value) … … 1579 1756 1580 1757 1581 # -ppc-target1758 #+ccl-68k-target 1582 1759 (defmethod %p-store-object (pheap (object t) descend) 1583 (if ( uvectorp object)1760 (if (ccl::uvectorp object) 1584 1761 (if (ccl::%lfun-vector-p object) 1585 1762 (%p-store-lfun-vector pheap object descend) … … 1590 1767 ; No lfun vectors on the PPC 1591 1768 (defmethod %p-store-object (pheap (object t) descend) 1592 (if ( uvectorp object)1769 (if (ccl::uvectorp object) 1593 1770 (%p-store-uvector pheap object descend) 1594 1771 (error "Don't know how to store ~s" object))) 1595 1772 1596 #+ppc-target 1597 ; Some ppc fixnums aren't Wood fixnums 1598 (defmethod %p-store-object (pheap (object fixnum) descend) 1599 (if (%ccl2-fixnum-p object) 1773 #+LispWorks 1774 (defmethod %p-store-object (pheap (object t) descend) 1775 (error "Don't know how to store ~s" object)) 1776 1777 (defun %p-store-as-uvector (pheap object descend length subtype) 1778 (%p-store-object-body (pheap object descend disk-cache address) 1779 (dc-make-uvector disk-cache length subtype) 1780 (let ((store-function (or (svref *p-store-subtype-functions* subtype) 1781 (error "Can't store vector of subtype ~s: ~s" subtype object)))) 1782 (funcall store-function pheap object descend disk-cache address length)))) 1783 1784 #+CCL 1785 (defun %p-store-uvector (pheap object descend) 1786 (%p-store-as-uvector pheap object descend 1787 (uvsize object) 1788 (uvector-subtype object))) 1789 1790 1791 #-ccl-68k-target 1792 (defmethod %p-store-object (pheap (object integer) descend) 1793 (if #+ccl (%ccl2-fixnum-p object) #+LispWorks (fixnump object) 1600 1794 (progn 1601 1795 ; We should only get here if %ccl2-fixnum-p is false. 1602 1796 (cerror "Do the right thing" "Object, ~s, doesn't satisfy ~s" object '%ccl2-fixnum-p) 1603 1797 (values object t)) 1604 (p-store-bignum pheap object descend))) 1605 1606 (defun %p-store-uvector (pheap object descend) 1607 (let* ((length (uvsize object)) 1608 (subtype (ccl->wood-subtype (ccl::%vect-subtype object))) 1609 (store-function (or (svref *p-store-subtype-functions* subtype) 1610 (error "Can't store vector of subtype ~s: ~s" subtype object)))) 1611 #+ppc-target 1612 (when (eql subtype $v_arrayh) 1613 (return-from %p-store-uvector 1614 (p-store-arrayh pheap object descend))) 1615 #+ppc-target 1616 (when (eql subtype $v_bignum) 1617 (p-store-bignum pheap object descend)) 1618 #+ccl-3 1619 (when (eql subtype $v_nhash) 1620 (return-from %p-store-uvector 1621 (p-store-nhash pheap object descend))) 1622 (%p-store-object-body (pheap object descend disk-cache address) 1623 (dc-make-uvector disk-cache length subtype) 1624 (funcall store-function pheap object descend disk-cache address length)))) 1625 1626 #+ppc-target 1627 (defun p-store-bignum (pheap object descend) 1798 (let ((words (1+ (floor (integer-length (abs object)) 16)))) 1799 (%p-store-as-uvector pheap object descend words $v_bignum)))) 1800 1801 #-ccl-68k-target 1802 (defun p-store-bignum (pheap object descend disk-cache address words) 1803 (declare (ignore pheap descend)) 1628 1804 (let* ((negative? (< object 0)) 1629 1805 (abs (if negative? (- object) object)) 1630 (bits (integer-length abs))) 1631 (multiple-value-bind (words zero-bits) (ceiling bits 16) 1632 (declare (fixnum words bits)) 1633 (when (eql 0 zero-bits) 1634 (incf words)) 1635 (%p-store-object-body (pheap object descend disk-cache address) 1636 (declare (ignore object)) 1637 (dc-make-uvector disk-cache words $v_bignum) 1638 (let ((position 0) 1639 (index (* 2 (1- words)))) 1640 (declare (fixnum index)) 1641 (accessing-disk-cache (disk-cache (+ address $v_data)) 1642 (dotimes (i words) 1643 (let ((word (if (> position bits) 0 (ccl::load-byte 16 position abs)))) 1644 (declare (fixnum word)) 1645 (when (and negative? (eql index 0)) 1646 (setq word (logior #x8000 word))) 1647 (store.w word index) 1648 (incf position 16) 1649 (decf index 2))))))))) 1806 (bits (integer-length abs)) 1807 (position 0) 1808 (index (* 2 (1- words)))) 1809 (declare (fixnum index)) 1810 (accessing-disk-cache (disk-cache (+ address $v_data)) 1811 (dotimes (i words) 1812 (let ((word (if (> position bits) 1813 0 1814 #+ccl (ccl::load-byte 16 position abs) 1815 #-ccl (ldb (byte 16 position) abs)))) 1816 (declare (fixnum word)) 1817 (when (and negative? (eql index 0)) 1818 (setq word (logior #x8000 word))) 1819 (store.w word index) 1820 (incf position 16) 1821 (decf index 2)))))) 1822 1823 #+LispWorks 1824 (progn 1825 1826 (defmethod %p-store-object (pheap (object ratio) descend) 1827 (%p-store-as-uvector pheap object descend 2 $v_ratio)) 1828 1829 (defun p-store-ratio (pheap object descend disk-cache address length) 1830 (declare (ignore length)) 1831 (multiple-value-bind (element imm?) (%p-store pheap (numerator object) descend) 1832 (setf (dc-%svref disk-cache address 0 imm?) element)) 1833 (multiple-value-bind (element imm?) (%p-store pheap (denominator object) descend) 1834 (setf (dc-%svref disk-cache address 1 imm?) element))) 1835 1836 (defun p-load-ratio (pheap disk-cache pointer depth subtype) 1837 (declare (ignore depth subtype)) 1838 (maybe-cached-value pheap pointer 1839 (let* ((num (dc-%svref-value pheap disk-cache pointer 0)) 1840 (den (dc-%svref-value pheap disk-cache pointer 1))) 1841 (/ num den)))) 1842 1843 (defmethod %p-store-object (pheap (object complex) descend) 1844 (%p-store-as-uvector pheap object descend 2 $v_complex)) 1845 1846 (defun p-store-complex (pheap object descend disk-cache address length) 1847 (declare (ignore length)) 1848 (multiple-value-bind (element imm?) (%p-store pheap (realpart object) descend) 1849 (setf (dc-%svref disk-cache address 0 imm?) element)) 1850 (multiple-value-bind (element imm?) (%p-store pheap (imagpart object) descend) 1851 (setf (dc-%svref disk-cache address 1 imm?) element))) 1852 1853 (defun p-load-complex (pheap disk-cache pointer depth subtype) 1854 (declare (ignore depth subtype)) 1855 (maybe-cached-value pheap pointer 1856 (let* ((real (dc-%svref-value pheap disk-cache pointer 0)) 1857 (imag (dc-%svref-value pheap disk-cache pointer 1))) 1858 (complex real imag)))) 1859 ) 1860 1861 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1862 (defun-inline %arrayh-overhead (object) 1863 (let* ((rank (array-rank object))) 1864 (if (eql rank 1) 1865 (+ $arh.fill 1) 1866 (+ $arh.dims rank 1)))) 1650 1867 1651 1868 #+ppc-target 1652 (defun p-store-arrayh (pheap object descend) 1653 (assert (ccl::%array-is-header object)) 1654 (multiple-value-bind (displaced-to offset) (displaced-array-p object) 1655 (let* ((rank (array-rank object)) 1656 (dims (unless (eql rank 1) (array-dimensions object))) 1657 (total-size (array-total-size object)) 1658 (fill (and (eql rank 1) (array-has-fill-pointer-p object) (fill-pointer object))) 1659 (simple (ccl::simple-array-p object)) 1660 (subtype (old-wood->ccl-subtype (ccl->wood-subtype (ccl::%array-header-subtype object)))) 1661 (adjustable (adjustable-array-p object)) 1662 (length (if (eql rank 1) 1663 (+ $arh.fill 1) 1664 (+ $arh.dims rank 1))) 1665 (bits (+ (if fill (ash 1 $arh_fill_bit) 0) 1666 (if simple (ash 1 $arh_simple_bit) 0) 1667 (if (ccl::%array-is-header displaced-to) (ash 1 $arh_disp_bit) 0) 1668 (if adjustable (ash 1 $arh_adjp_bit) 0))) 1669 (flags (+ (ash rank (+ 2 16 -3)) 1670 (ash subtype (+ 8 -3)) 1671 (ash bits -3)))) 1672 (unless (fixnump flags) 1673 (error "Array header flags not a fixnum. Rank must be too big.")) 1674 (unless displaced-to 1675 (error "~s should be displaced but isn't")) 1676 (%p-store-object-body (pheap object descend disk-cache address) 1677 (declare (ignore object)) 1678 (dc-make-uvector disk-cache length $v_arrayh) 1679 (progn 1680 (dc-%svfill disk-cache address 1681 ($arh.fixnum t) flags 1682 ($arh.offs t) offset) 1683 (if (eql rank 1) 1684 (dc-%svfill disk-cache address 1685 ($arh.vlen t) total-size 1686 ($arh.fill t) (or fill total-size)) 1687 (progn 1688 (setf (dc-%svref disk-cache address $arh.dims t) rank) 1689 (dotimes (i rank) 1690 (setf (dc-%svref disk-cache address (+ $arh.fill i) t) 1691 (pop dims))))) 1692 (setf (dc-%svref disk-cache address $arh.vect) 1693 (%p-store pheap displaced-to descend))))))) 1869 (defmethod %p-store-object (pheap (object array) descend) 1870 (if (ccl::%array-is-header object) 1871 (%p-store-as-uvector pheap object descend (%arrayh-overhead object) $v_arrayh) 1872 (%p-store-uvector pheap object descend))) 1873 1874 #+LispWorks 1875 (defmethod %p-store-object (pheap (object array) descend) 1876 (if (displaced-array-p object) 1877 (%p-store-as-uvector pheap object descend (%arrayh-overhead object) $v_arrayh) 1878 (let ((subtype (uvector-subtype object))) 1879 (if (and subtype (typep object 'simple-array) (vectorp object)) 1880 (%p-store-as-uvector pheap object descend (array-total-size object) subtype) 1881 (let* ((overhead (%arrayh-overhead object)) 1882 (num-elements (array-total-size object))) 1883 (if (or (null subtype) (eq subtype $v_genv)) 1884 (%p-store-as-uvector pheap object descend (+ overhead num-elements) $v_garrayh) 1885 (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)) 1886 (data-bytes (ceiling (* num-elements bytes-per-element))) 1887 (total-bytes (+ (* overhead 4) data-bytes))) 1888 (%p-store-as-uvector pheap object descend total-bytes $v_iarrayh)))))))) 1889 1890 1891 (defun %store-array-header-slots (pheap disk-cache address object) 1892 (let* ((displaced-offset (or (nth-value 1 (displaced-array-p object)) 0)) 1893 (rank (array-rank object)) 1894 (dims (unless (eql rank 1) (array-dimensions object))) 1895 (total-size (array-total-size object)) 1896 (fill (and (eql rank 1) (array-has-fill-pointer-p object) (fill-pointer object))) 1897 #+ccl (simple (ccl::simple-array-p object)) 1898 (subtype #+ccl (old-wood->ccl-subtype (ccl->wood-subtype (ccl::%array-header-subtype object))) 1899 #-ccl (or (uvector-subtype object) $v_badptr)) 1900 (adjustable (adjustable-array-p object)) 1901 (bits (+ (if fill (ash 1 $arh_fill_bit) 0) 1902 #+ccl (if simple (ash 1 $arh_simple_bit) 0) 1903 (if #+ccl (ccl::%array-is-header displaced-to) 1904 #-ccl (displaced-array-p object) 1905 (ash 1 $arh_disp_bit) 0) 1906 (if adjustable (ash 1 $arh_adjp_bit) 0))) 1907 (flags (+ (ash rank (+ 2 16 -3)) 1908 (ash (or subtype $v_badptr) (+ 8 -3)) 1909 (ash bits -3)))) 1910 (unless (fixnump flags) 1911 (error "Array header flags not a fixnum. Rank must be too big.")) 1912 (dc-%svfill disk-cache address 1913 ($arh.fixnum t) flags 1914 ($arh.offs t) displaced-offset) 1915 (if (eql rank 1) 1916 (dc-%svfill disk-cache address 1917 ($arh.vlen t) total-size 1918 ($arh.fill t) (or fill total-size)) 1919 (progn 1920 (setf (dc-%svref disk-cache address $arh.dims t) rank) 1921 (dotimes (i rank) 1922 (setf (dc-%svref disk-cache address (+ $arh.fill i) t) 1923 (pop dims))))) 1924 #+LispWorks 1925 (when (eql subtype $v_badptr) 1926 (setf (dc-%svref disk-cache address $arh.etype) 1927 (%p-store pheap (array-element-type object) :default))))) 1928 1929 #-ccl-68k-target 1930 (defun p-store-arrayh (pheap object descend disk-cache address length) 1931 (declare (ignore length)) 1932 #+ccl (assert (ccl::%array-is-header object)) 1933 (%store-array-header-slots pheap disk-cache address object) 1934 (let ((displaced-to (displaced-array-p object))) 1935 (unless displaced-to 1936 (error "~s should be displaced but isn't" object)) 1937 (setf (dc-%svref disk-cache address $arh.vect) 1938 (%p-store pheap displaced-to descend)))) 1939 1940 #+LispWorks 1941 (defun p-store-garrayh (pheap object descend disk-cache address length) 1942 (%store-array-header-slots pheap disk-cache address object) 1943 (setf (dc-%svref disk-cache address $arh.vect) $pheap-nil) 1944 (let* (($arh.data (%arrayh-overhead object)) 1945 (total-size (array-total-size object))) 1946 (assert (eql (+ $arh.data total-size) length)) 1947 (dotimes (i total-size) 1948 (multiple-value-bind (element imm?) (%p-store pheap (row-major-aref object i) descend) 1949 (setf (dc-%svref disk-cache address (+ $arh.data i) imm?) element))))) 1950 1951 #+LispWorks 1952 (defun p-store-iarrayh (pheap object descend disk-cache address num-bytes) 1953 (declare (ignore descend)) 1954 (%store-array-header-slots pheap disk-cache address object) 1955 (setf (dc-%svref disk-cache address $arh.vect) $pheap-nil) 1956 (let* ((overhead-bytes (* 4 (%arrayh-overhead object)))) 1957 (store-bytes-from-iarray object disk-cache 1958 (addr+ disk-cache address (- overhead-bytes $t_vector)) 1959 (- num-bytes overhead-bytes)))) 1694 1960 1695 1961 (defun p-store-gvector (pheap object descend disk-cache address length) … … 1701 1967 (declare (ignore pheap descend length)) 1702 1968 (let* ((bytes (dc-%vector-size disk-cache address))) 1703 (store-byte -array object disk-cache (addr+ disk-cache address $v_data) bytes 0 t)))1704 1705 # +ppc-target1969 (store-bytes-from-ivector object disk-cache (addr+ disk-cache address $v_data) bytes))) 1970 1971 #-ccl-68k-target 1706 1972 (defun p-store-bit-vector (pheap object descend disk-cache address length) 1707 1973 (declare (ignore pheap descend length)) 1708 1974 (let* ((bytes (dc-%vector-size disk-cache address))) 1709 (declare (fixnum bytes))1710 (store-byte -array object disk-cache (addr+ disk-cache address (1+ $v_data)) (1- bytes) 0 t)))1711 1712 # -ppc-target1975 #-LispWorks(declare (fixnum bytes)) 1976 (store-bytes-from-bit-vector object disk-cache (addr+ disk-cache address (1+ $v_data)) (1- bytes)))) 1977 1978 #+ccl-68k-target 1713 1979 (defun %p-store-lfun-vector (pheap object descend) 1714 1980 (%p-store-object-body (pheap object descend disk-cache address) … … 1719 1985 pheap disk-cache address load-function.args nil descend)))) 1720 1986 1987 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1988 #+ccl 1721 1989 (defmethod p-make-load-function-using-pheap ((pheap pheap) (hash hash-table)) 1722 1990 (let ((rehashF (function-name (ccl::nhash.rehashF hash))) … … 1736 2004 ,vector ,count ,locked-additions))))) 1737 2005 2006 #+ccl 1738 2007 (defun %initialize-hash-table (hash rehashF keytransF compareF vector count locked-additions) 1739 2008 (flet ((convert (f) … … 1752 2021 (ccl::%maybe-rehash hash)))) 1753 2022 1754 # -ccl-32023 #+(and ccl (not ccl-3)) 1755 2024 (defun p-load-nhash (pheap disk-cache pointer depth subtype) 1756 2025 (p-load-header pheap disk-cache pointer depth subtype)) … … 1767 2036 (defconstant $nhash.vector-overhead-delta 1768 2037 (- $new-nhash.vector-overhead $old-nhash.vector-overhead)) 2038 2039 (defmethod %p-store-object (pheap (object hash-table) descend) 2040 (let* ((old-length (- (ccl::uvsize object) $nhash.vector-overhead-delta))) 2041 #-LispWorks (declare (fixnum length old-length)) 2042 (%p-store-as-uvector pheap object descend old-length $v_nhash))) 1769 2043 1770 2044 (defun p-load-nhash (pheap disk-cache pointer depth subtype) … … 1779 2053 (res (ccl::%cons-nhash-vector element-count)) 1780 2054 (res-length (uvsize res))) 1781 (declare (fixnum disk-length pairs element-count res-length)) 2055 #-LispWorks (declare (fixnum disk-length pairs element-count res-length)) 2056 #+LispWorks (assert (and (fixnump disk-length) 2057 (fixnump pairs) 2058 (fixnump element-count) 2059 (fixnump res-length))) 1782 2060 (assert (eql (the fixnum (- length $old-nhash.vector-overhead)) 1783 2061 (the fixnum (- res-length $new-nhash.vector-overhead)))) … … 1803 2081 vector)) 1804 2082 1805 (defun p-store-nhash (pheap object descend) 1806 (let* ((length (uvsize object)) 1807 (old-length (- length $nhash.vector-overhead-delta))) 1808 (declare (fixnum length old-length)) 1809 (%p-store-object-body (pheap object descend disk-cache address) 1810 (dc-make-uvector disk-cache old-length $v_nhash) 1811 (progn 1812 (setf (dc-%svref disk-cache address $old-nhash.vector-header-size) $pheap-nil) 1813 (dotimes (i length) 1814 (declare (fixnum i)) 1815 (let ((j i)) 1816 (declare (fixnum j)) 1817 (unless (and (>= i $old-nhash.vector-header-size) 1818 (progn (decf j $nhash.vector-overhead-delta) 1819 (< i $new-nhash.vector-overhead))) 1820 (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend) 1821 (setf (dc-%svref disk-cache address j imm?) element))))))))) 1822 2083 (defun p-store-nhash (pheap object descend disk-cache address old-length) 2084 (declare (ignore old-length)) 2085 (let ((length (ccl::uvsize object))) 2086 (setf (dc-%svref disk-cache address $old-nhash.vector-header-size) $pheap-nil) 2087 (dotimes (i length) 2088 (declare (fixnum i)) 2089 (let ((j i)) 2090 (declare (fixnum j)) 2091 (unless (and (>= i $old-nhash.vector-header-size) 2092 (progn (decf j $nhash.vector-overhead-delta) 2093 (< i $new-nhash.vector-overhead))) 2094 (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend) 2095 (setf (dc-%svref disk-cache address j imm?) element))))))) 1823 2096 ) ; end of progn 2097 2098 2099 #+LispWorks 2100 (progn 2101 2102 (def-indices 2103 $hash.test 2104 $hash.size 2105 $hash.rehash-size 2106 $hash.rehash-threshold 2107 $hash.hash-function 2108 $hash.weak-kind 2109 $hash.data) 2110 2111 (defun hash-table-hash-function (hash) 2112 (cdr (system::hash-table-user-stuff hash))) 2113 2114 (defun p-load-nhash (pheap disk-cache pointer depth subtype) 2115 (assert (eql subtype $v_nhash)) 2116 (flet ((load (index) 2117 (dc-%svref-value pheap disk-cache pointer index))) 2118 (declare (inline load)) 2119 (let* ((cached? t) 2120 (hash (maybe-cached-value pheap pointer 2121 (setq cached? nil) 2122 (let* ((test (load $hash.test)) 2123 (size (load $hash.size)) 2124 (rehash-size (load $hash.rehash-size)) 2125 (rehash-threshold (load $hash.rehash-threshold)) 2126 (hash-function (load $hash.hash-function)) 2127 (weak-kind (load $hash.weak-kind))) 2128 (make-hash-table :test test :size size 2129 :rehash-size rehash-size 2130 :rehash-threshold rehash-threshold 2131 :hash-function hash-function 2132 :weak-kind weak-kind))))) 2133 (when (or (not cached?) 2134 (and (eq depth t) 2135 (let ((p-load-hash (p-load-hash pheap))) 2136 (unless (gethash hash p-load-hash) 2137 (setf (gethash hash p-load-hash) hash))))) 2138 (when cached? 2139 (unless (and (equal (load $hash.test) (hash-table-test hash)) 2140 (equal (load $hash.rehash-size) (hash-table-rehash-size hash)) 2141 (equal (load $hash.rehash-threshold) (hash-table-rehash-threshold hash)) 2142 (equal (load $hash.hash-function) (hash-table-hash-function hash)) 2143 (equal (load $hash.weak-kind) (system::hash-table-weak-kind hash))) 2144 (error "Incompatible parameters for ~s" hash)) 2145 (clrhash hash)) 2146 (loop for i from $hash.data below (dc-%simple-vector-length disk-cache pointer) by 2 2147 as key = (load i) 2148 as value = (load (1+ i)) 2149 do (setf (gethash key hash) value)) 2150 hash)))) 2151 2152 (defmethod %p-store-object (pheap (object hash-table) descend) 2153 (let ((length (+ $hash.data (* 2 (hash-table-count object))))) 2154 (%p-store-as-uvector pheap object descend length $v_nhash))) 2155 2156 (defun p-store-nhash (pheap object descend disk-cache address length) 2157 (declare (ignore length)) 2158 (flet ((store (index value) 2159 (multiple-value-bind (element imm?) (%p-store pheap value descend) 2160 (setf (dc-%svref disk-cache address index imm?) element)))) 2161 (declare (inline store)) 2162 (store $hash.test (hash-table-test object)) 2163 (store $hash.size (hash-table-size object)) 2164 (store $hash.rehash-size (hash-table-rehash-size object)) 2165 (store $hash.rehash-threshold (hash-table-rehash-threshold object)) 2166 (store $hash.hash-function (hash-table-hash-function object)) 2167 (store $hash.weak-kind (system::hash-table-weak-kind object)) 2168 (loop for i from $hash.data by 2 2169 for key being the hash-key of object using (hash-value value) 2170 do (store i key) 2171 do (store (1+ i) value)))) 2172 2173 ) ;#+LispWorks 2174 2175 2176 1824 2177 1825 2178 ;;;;;;;;;;;;;;;;;;;;;;;;;; … … 1884 2237 `(progn 1885 2238 (defun ,p-name (,p ,@args) 1886 ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?))) )2239 ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?))) #+LispWorks `((declare (ignore ignore)))) 1887 2240 (p-dispatch (,p ,@args-sans-keywords) 1888 2241 ,dc-name ,lisp-accessor t ,rest-arg?)) 1889 (defun ,dc-name (,disk-cache ,pointer ,@args) 2242 ;; Workaround for stupid LispWorks compiler fascism: when compiling (setf (foo ...) value), 2243 ;; it requires that ... must match FOO's arglist. Since our (setf dc-xxx) method take an extra 2244 ;; imm? arg, put in a fake extra arg into the non-setf form as well. 2245 (defun ,dc-name (,disk-cache ,pointer ,@args #+LispWorks ,@(unless rest-arg? '(&optional ignore))) 2246 #+lispWorks ,@(unless rest-arg? `((declare (ignore ignore)))) 1890 2247 ,@body)))) 1891 2248 … … 1935 2292 (pointer-tagp pointer $t_symbol)) 1936 2293 2294 (defun-inline %array-subtype-p (subtype) 2295 (declare (fixnum subtype)) 2296 (or (and (<= $v_min_arr subtype) (<= subtype $v_arrayh)) 2297 #+LispWorks (eql subtype $v_garrayh) 2298 #+LispWorks (eql subtype $v_iarrayh))) 2299 2300 (defun-inline %arrayh-subtype-p (subtype) 2301 (declare (fixnum subtype)) 2302 (or (eql $v_arrayh subtype) 2303 #+LispWorks (eql $v_garrayh subtype) 2304 #+LispWorks (eql $v_iarrayh subtype))) 2305 2306 1937 2307 (def-predicate arrayp (p disk-cache pointer) 1938 2308 (and (pointer-tagp pointer $t_vector) 1939 (let ((subtype (dc-%vector-subtype disk-cache pointer))) 1940 (declare (fixnum subtype)) 1941 (and (<= $v_min_arr subtype) (<= subtype $v_arrayh))))) 2309 (%array-subtype-p (dc-%vector-subtype disk-cache pointer)))) 2310 2311 (defun dc-array-header-p (disk-cache pointer) 2312 (and (pointer-tagp pointer $t_vector) 2313 (%arrayh-subtype-p (dc-%vector-subtype disk-cache pointer)))) 1942 2314 1943 2315 (defun dc-array-subtype-satisfies-p (disk-cache array predicate) 1944 2316 (and (pointer-tagp array $t_vector) 1945 2317 (let ((subtype (dc-%vector-subtype disk-cache array))) 1946 (if ( eql $v_arrayhsubtype)2318 (if (%arrayh-subtype-p subtype) 1947 2319 (values 1948 2320 (funcall predicate … … 1951 2323 (funcall predicate subtype))))) 1952 2324 2325 ;; TODO: this isn't enough for LispWorks, lispworks sys:augmented-string is 2326 ;; a $v_garrayh array with element-type = 'character. 1953 2327 (def-predicate stringp (p disk-cache pointer) 1954 2328 (multiple-value-bind (stringp arrayhp) 1955 2329 (dc-array-subtype-satisfies-p 1956 2330 disk-cache pointer 1957 #'(lambda (x) ( eql x $v_sstr)))2331 #'(lambda (x) (or (eql x $v_sstr) (eql x $v_xstr)))) 1958 2332 (and stringp 1959 2333 (or (not arrayhp) … … 1964 2338 (dc-array-subtype-satisfies-p 1965 2339 disk-cache pointer 1966 #'(lambda (x) 1967 (declare (fixnum x)) 1968 (and (<= $v_min_arr x) (< x $v_arrayh)))) 2340 #'%array-subtype-p) 1969 2341 (and arrayp 1970 2342 (or (not arrayhp) … … 2016 2388 (page-offset 0) 2017 2389 (offset (require-type offset 'fixnum))) 2018 (declare (fixnum page-size mask page-offset blocks-crossedoffset))2390 (declare (fixnum page-size mask page-offset offset)) 2019 2391 (macrolet ((doit () 2020 2392 `(progn … … 2034 2406 (doit))))) 2035 2407 2036 (def-accessor ccl::%svref (v index) (disk-cache v-pointer)2408 (def-accessor %svref (v index) (disk-cache v-pointer) 2037 2409 (read-pointer 2038 2410 disk-cache … … 2051 2423 2052 2424 (defun dc-%simple-vector-length (disk-cache pointer) 2053 (the fixnum (ash (the fixnum (read-low-24-bits 2054 disk-cache (+ pointer $v_log))) 2425 (the fixnum (ash (the #+ccl fixnum #+LispWorks integer 2426 (read-low-24-bits 2427 disk-cache (+ pointer $v_log))) 2055 2428 -2))) 2056 2429 … … 2058 2431 (read-8-bits disk-cache (+ pointer $v_subtype))) 2059 2432 2060 (def-accessor ccl::%vect-subtype (p) (disk-cache pointer) 2433 2434 (def-accessor %vect-subtype (p) (disk-cache pointer) 2061 2435 (values (dc-%vector-subtype disk-cache pointer) t)) 2062 2436 … … 2078 2452 (error "Inconsistency: pointer at ~s was not a fixnum." address-name)) 2079 2453 value)) 2454 2455 (defun dc-%svref-value (pheap disk-cache pointer index) 2456 (multiple-value-bind (value imm?) (dc-%svref disk-cache pointer index) 2457 (if imm? 2458 value 2459 (pointer-load pheap value :default disk-cache)))) 2460 2080 2461 2081 2462 (def-accessor car (p) (disk-cache pointer) … … 2203 2584 (nth n list))) 2204 2585 2205 (defun dc-nth (disk-cache n list) 2586 (defun dc-nth (disk-cache n list #+LispWorks &optional #+LispWorks ignore) 2587 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 2206 2588 (dc-car disk-cache (dc-nthcdr disk-cache n list))) 2207 2589 … … 2226 2608 (nthcdr n list))) 2227 2609 2228 (defun dc-nthcdr (disk-cache n list) 2610 (defun dc-nthcdr (disk-cache n list #+LispWorks &optional #+LispWorks ignore) 2611 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 2229 2612 (setq n (require-type n 'unsigned-byte)) 2230 2613 (loop … … 2240 2623 (setf (dc-nthcdr (pheap-disk-cache pheap) n (pptr-pointer list) imm?) pointer) 2241 2624 (if imm? pointer (pptr pheap pointer)))) 2242 (setf (nthcdr n list) value))) 2625 #+ccl(setf (nthcdr n list) value) 2626 #-ccl (if (eql n 0) value (setf (cdr (nthcdr (1- n) value)) value)))) 2243 2627 2244 2628 (defun (setf dc-nthcdr) (value disk-cache n list &optional imm?) … … 2355 2739 (unless (< -1 index size) 2356 2740 (error "Index ~s out of range for ~s" index (dc-pointer-pptr disk-cache pointer))) 2741 ;; #+LispWorks *** TODO: Check endianness 2357 2742 (values (addr+ disk-cache pointer (+ $v_data 1 (ash index -3))) 2358 2743 (- 7 (logand index 7))))) … … 2366 2751 0) 2367 2752 t))) 2368 2753 2369 2754 2370 2755 (defun (setf p-uvref) (value pptr index) … … 2443 2828 (setf (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset))) 2444 2829 (require-type value 'double-float)) 2830 ;; TODO: LispWorks doesn't actually stack-cons immediate arrays. Should just 2831 ;; copy directly 2445 2832 (let ((buf (make-string 8 :element-type 'base-character))) 2446 2833 (declare (dynamic-extent buf)) 2447 2834 (require-satisfies pointer-tagp value $t_dfloat) 2448 (load-byte -arraydisk-cache (- value $t_dfloat) 8 buf)2449 (store-byte -arraybuf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8)2450 value)))) 2835 (load-bytes-to-string disk-cache (- value $t_dfloat) 8 buf) 2836 (store-bytes-from-string buf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8) 2837 value)))) 2451 2838 2452 2839 (defun uvset-bit-vector (value disk-cache pointer index immediate?) … … 2473 2860 (pptr-pointer p)) 2474 2861 (values (pptr pheap address) offset))) 2475 ( ccl::array-data-and-offset p)))2862 (array-data-and-offset p))) 2476 2863 2477 2864 (defun dc-array-data-and-offset (disk-cache pointer) 2478 2865 (require-satisfies dc-arrayp disk-cache pointer) 2479 (if (not (dc- vector-subtype-p disk-cache pointer $v_arrayh))2866 (if (not (dc-array-header-p disk-cache pointer)) 2480 2867 (values pointer 0) 2481 2868 (let* ((p pointer) … … 2499 2886 2500 2887 (defun dc-%vector-length (disk-cache pointer) 2501 (if ( eql $v_arrayh(dc-%vector-subtype disk-cache pointer))2888 (if (%arrayh-subtype-p (dc-%vector-subtype disk-cache pointer)) 2502 2889 (if (logbitp $arh_fill_bit (dc-%arrayh-bits disk-cache pointer)) 2503 2890 (dc-%svref disk-cache pointer $arh.fill) … … 2527 2914 (def-accessor symbol-value (p) (disk-cache pointer) 2528 2915 (let ((values (dc-symbol-values-list disk-cache pointer))) 2529 (let ((value ( ccl::%unbound-marker-8))2916 (let ((value (%unbound-marker)) 2530 2917 (value-imm? t)) 2531 2918 (when values 2532 2919 (multiple-value-setq (value value-imm?) (dc-car disk-cache values))) 2533 (when (and value-imm? (eq value ( ccl::%unbound-marker-8)))2920 (when (and value-imm? (eq value (%unbound-marker))) 2534 2921 (dc-error "Unbound variable: ~s = ~s" disk-cache pointer)) 2535 2922 (values value value-imm?)))) … … 2956 3343 res))) 2957 3344 3345 #-LispWorks 2958 3346 (eval-when (:compile-toplevel :execute) 2959 3347 (assert (< (expt 2 24) most-positive-fixnum))) 2960 3348 3349 #-LispWorks 2961 3350 (assert (fixnump (1- (expt 2 24)))) 2962 3351 … … 2968 3357 (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)) 2969 3358 (size (* length bytes-per-element))) 2970 (unless (< size (expt 2 24))3359 (unless (<= size (- (min #.(1- (expt 2 24)) most-positive-fixnum) $vector-header-size)) 2971 3360 (error "Attempt to allocate a vector larger than ~s bytes long" 2972 ( 1- (expt 2 24))))3361 (- (min #.(1- (expt 2 24)) most-positive-fixnum) $vector-header-size))) 2973 3362 (locally (declare (fixnum size)) 2974 3363 (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size size)))) … … 3018 3407 ; Try the next segment in the free list 3019 3408 (%allocate-storage-internal 3020 disk-cache area free-link size segment initial-segment)3409 disk-cache area #+remove free-link size segment initial-segment) 3021 3410 ; Does not fit in any of the existing segments. Make a new one. 3022 3411 (let ((new-segment (dc-cons-segment … … 3151 3540 (0) 3152 3541 (1 (setq initial-element #xff)))) 3153 (locally (declare (fixnum bytes))3542 (locally #-LispWorks(declare (fixnum bytes)) 3154 3543 (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size bytes))) 3155 3544 (res (initialize-vector-storage … … 3278 3667 (p-uvector pheap $v_weakh nil type data)) 3279 3668 3669 #+CCL 3280 3670 (def-accessor ccl::population-data (p) (disk-cache pointer) 3281 3671 (require-satisfies dc-vector-subtype-p disk-cache pointer $v_weakh) … … 3555 3945 (return-from %p-store-hash-key nil)))))))) 3556 3946 3947 (defconstant $null-char (code-char 0)) 3948 3557 3949 (defmacro with-dc-hash-key ((key-var key key-imm?) &body body) 3558 3950 (let ((s4 (gensym)) … … 3568 3960 (%store-pointer ,key ,s4 0 ,key-imm?) 3569 3961 (locally (declare (optimize (speed 3) (safety 0))) 3570 (if (eql #\000(schar ,s4 0))3571 (if (eql #\000(schar ,s4 1))3572 (if (eql #\000(schar ,s4 2))3962 (if (eql $null-char (schar ,s4 0)) 3963 (if (eql $null-char (schar ,s4 1)) 3964 (if (eql $null-char (schar ,s4 2)) 3573 3965 (setf (schar ,s1 0) (schar ,s4 3) 3574 3966 ,key-var ,s1) … … 3592 3984 (setf (schar s 1) 3593 3985 (setf (schar s 2) 3594 (setf (schar s 3) #\000)))))3986 (setf (schar s 3) $null-char))))) 3595 3987 (if (> len 4) (error "Bad hash-table key-string: ~s" key-string)) 3596 3988 (%copy-byte-array-portion key-string 0 len s (the fixnum (- 4 len))) … … 3691 4083 (if (pptr-p p) 3692 4084 (dc-vector-subtype-p (pptr-disk-cache p) (pptr-pointer p) subtype) 3693 ( ccl::uvector-subtype-p p subtype)))4085 (uvector-subtype-p p subtype))) 3694 4086 3695 4087 (defun pload-barrier-p (object) … … 3702 4094 ;;; 3703 4095 4096 3704 4097 (defparameter *p-load-subtype-functions* 3705 #(p-load-error ;($v_packed_sstr 0) 3706 p-load-bignum ;($v_bignum 1) 3707 p-load-error ;($v_macptr 2) - not supported 3708 p-load-ivector ;($v_badptr 3) 3709 p-load-lfun-vector ;($v_nlfunv 4) 3710 p-load-error ;subtype 5 unused 3711 p-load-ivector ;($v_xstr 6) ;extended string 3712 p-load-ivector ;($v_ubytev 7) ;unsigned byte vector 3713 p-load-ivector ;($v_uwordv 8) ;unsigned word vector 3714 p-load-ivector ;($v_floatv 9) ;float vector 3715 p-load-ivector ;($v_slongv 10) ;Signed long vector 3716 p-load-ivector ;($v_ulongv 11) ;Unsigned long vector 3717 #-ppc-target p-load-ivector ;($v_bitv 12) ;Bit vector 3718 #+ppc-target p-load-bit-vector 3719 p-load-ivector ;($v_sbytev 13) ;Signed byte vector 3720 p-load-ivector ;($v_swordv 14) ;Signed word vector 3721 p-load-ivector ;($v_sstr 15) ;simple string 3722 p-load-gvector ;($v_genv 16) ;simple general vector 3723 p-load-arrayh ;($v_arrayh 17) ;complex array header 3724 p-load-struct ;($v_struct 18) ;structure 3725 p-load-error ;($v_mark 19) ;buffer mark 3726 p-load-pkg ;($v_pkg 20) 3727 p-load-error ;subtype 21 unused 3728 p-load-istruct ;($v_istruct 22) 3729 p-load-ivector ;($v_ratio 23) 3730 p-load-ivector ;($v_complex 24) 3731 p-load-instance ;($v_instance 25) ;clos instance 3732 p-load-error ;subtype 26 unused 3733 p-load-error ;subtype 27 unused 3734 p-load-error ;subtype 28 unused 3735 p-load-header ;($v_weakh 29) 3736 p-load-header ;($v_poolfreelist 30) 3737 p-load-nhash ;($v_nhash 31) 3738 ; internal subtypes 3739 p-load-nop ;($v_area 32) 3740 p-load-nop ;($v_segment 33) 3741 p-load-nop ;($v_random-bits 34) 3742 p-load-nop ;($v_dbheader 35) 3743 p-load-nop ;($v_segment-headers 36) 3744 p-load-nop ;($v_btree 37) 3745 p-load-nop ;($v_btree-node 38) 3746 p-load-class ;($v_class 39) 3747 p-load-load-function ;($v_load-function 40) 3748 p-load-pload-barrier ;($v_pload-barrier 41) 3749 )) 4098 (vtype-vector :unused p-load-error 4099 :bignum p-load-bignum 4100 #+ccl :badptr #+ccl p-load-ivector 4101 #+ccl :nlfunv #+ccl p-load-lfun-vector 4102 :xstr p-load-ivector 4103 :ubytev p-load-ivector 4104 :uwordv p-load-ivector 4105 :floatv p-load-ivector 4106 :slongv p-load-ivector 4107 :ulongv p-load-ivector 4108 :bitv #+ccl-68k-target p-load-ivector #-ccl-68k-target p-load-bit-vector 4109 :sbytev p-load-ivector 4110 :swordv p-load-ivector 4111 :sstr p-load-ivector 4112 :genv p-load-gvector 4113 :arrayh p-load-arrayh 4114 #+LispWorks :garrayh #+LispWorks p-load-arrayh 4115 #+LispWorks :iarrayh #+LispWorks p-load-arrayh 4116 :struct p-load-struct 4117 :pkg p-load-pkg 4118 #+ccl :istruct #+ccl p-load-istruct 4119 :ratio #+ccl p-load-ivector #-ccl p-load-ratio 4120 :complex #+ccl p-load-ivector #-ccl p-load-complex 4121 :instance p-load-instance 4122 #+ccl :weakh #+ccl p-load-header 4123 #+ccl :poolfreelist #+ccl p-load-header 4124 :nhash p-load-nhash 4125 :area p-load-nop 4126 :segment p-load-nop 4127 :random-bits p-load-nop 4128 :dbheader p-load-nop 4129 :segment-headers p-load-nop 4130 :btree p-load-nop 4131 :btree-node p-load-nop 4132 :class p-load-class 4133 :load-function p-load-load-function 4134 :pload-barrier p-load-pload-barrier)) 3750 4135 3751 4136 (defparameter *subtype->bytes-per-element* 3752 #(nil ; 0 - unused 3753 2 ; 1 - $v_bignum 3754 nil ; 2 - $v_macptr - not supported 3755 4 ; 3 - $v_badptr 3756 2 ; 4 - $v_nlfunv 3757 nil ; 5 - unused 3758 2 ; 6 - $v_xstr - extended string 3759 1 ; 7 - $v_ubytev - unsigned byte vector 3760 2 ; 8 - $v_uwordv - unsigned word vector 3761 8 ; 9 - $v_floatv - float vector 3762 4 ; 10 - $v_slongv - Signed long vector 3763 4 ; 11 - $v_ulongv - Unsigned long vector 3764 nil ; 12 - $v_bitv - Bit vector (handled specially) 3765 1 ; 13 - $v_sbytev - Signed byte vector 3766 2 ; 14 - $v_swordv - Signed word vector 3767 1 ; 15 - $v_sstr - simple string 3768 4 ; 16 - $v_genv - simple general vector 3769 4 ; 17 - $v_arrayh - complex array header 3770 4 ; 18 - $v_struct - structure 3771 nil ; 19 - $v_mark - buffer mark unimplemented 3772 4 ; 20 - $v_pkg 3773 nil ; 21 - unused 3774 4 ; 22 - $v_istruct - type in first element 3775 4 ; 23 - $v_ratio 3776 4 ; 24 - $v_complex 3777 4 ; 25 - $v_instance - clos instance 3778 nil ; 26 - unused 3779 nil ; 27 - unused 3780 nil ; 28 - unused 3781 4 ; 29 - $v_weakh - weak list header 3782 4 ; 30 - $v_poolfreelist - free pool header 3783 4 ; 31 - $v_nhash 3784 ; WOOD specific subtypes 3785 4 ; 32 - $v_area - area descriptor 3786 4 ; 33 - $v_segment - area segment 3787 1 ; 34 - $v_random-bits - vectors of random bits, e.g. resources 3788 4 ; 35 - $v_dbheader - database header 3789 nil ; 36 - $v_segment-headers - specially allocated 3790 4 ; 37 - $v_btree 3791 nil ; 38 - $v_btree-node - specially allocated 3792 4 ; 39 - $v_class 3793 4 ; 40 - $v_load-function 3794 4 ;($v_pload-barrier 41) 3795 )) 4137 (vtype-vector :bignum 2 4138 :badptr 4 4139 :nlfunv 2 4140 :xstr 2 4141 :ubytev 1 4142 :uwordv 2 4143 :floatv 8 4144 :slongv 4 4145 :ulongv 4 4146 :bitv 1/8 4147 :sbytev 1 4148 :swordv 2 4149 :sstr 1 4150 :genv 4 4151 :arrayh 4 4152 :garrayh 4 4153 :iarrayh 1 4154 :struct 4 4155 :pkg 4 4156 :istruct 4 4157 :ratio 4 4158 :complex 4 4159 :instance 4 4160 :weakh 4 4161 :poolfreelist 4 4162 :nhash 4 4163 :area 4 4164 :segment 4 4165 :random-bits 1 4166 :dbheader 4 4167 :btree 4 4168 :class 4 4169 :load-function 4 4170 :pload-barrier 4)) 4171 4172 4173 #+LispWorks 4174 (defparameter *subtype->array-byte-offset* 4175 (vtype-vector :unused 0 4176 :floatv #.$floatv-read-offset)) 4177 4178 4179 #+LispWorks 4180 (defparameter *subtype->array-element-type* 4181 (vtype-vector :xstr simple-character 4182 :ubytev (unsigned-byte 8) 4183 :uwordv (unsigned-byte 16) 4184 :floatv double-float 4185 :slongv (signed-byte 32) 4186 :ulongv (unsigned-byte 32) 4187 :bitv (unsigned-byte 1) 4188 :sbytev (signed-byte 8) 4189 :swordv (signed-byte 16) 4190 :sstr base-character 4191 :genv t)) 4192 4193 3796 4194 3797 4195 (defparameter *p-store-subtype-functions* 3798 #(nil ;($v_packed_sstr 0) 3799 p-store-ivector ;($v_bignum 1) 3800 nil ;($v_macptr 2) - not supported 3801 p-store-ivector ;($v_badptr 3) 3802 nil ;($v_nlfunv 4) 3803 nil ;subtype 5 unused 3804 p-store-ivector ;($v_xstr 6) ;16-bit string 3805 p-store-ivector ;($v_ubytev 7) ;unsigned byte vector 3806 p-store-ivector ;($v_uwordv 8) ;unsigned word vector 3807 p-store-ivector ;($v_floatv 9) ;float vector 3808 p-store-ivector ;($v_slongv 10) ;Signed long vector 3809 p-store-ivector ;($v_ulongv 11) ;Unsigned long vector 3810 #-ppc-target p-store-ivector ;($v_bitv 12) ;Bit vector 3811 #+ppc-target p-store-bit-vector 3812 p-store-ivector ;($v_sbytev 13) ;Signed byte vector 3813 p-store-ivector ;($v_swordv 14) ;Signed word vector 3814 p-store-ivector ;($v_sstr 15) ;simple string 3815 p-store-gvector ;($v_genv 16) ;simple general vector 3816 p-store-gvector ;($v_arrayh 17) ;complex array header 3817 p-store-gvector ;($v_struct 18) ;structure 3818 nil ;($v_mark 19) ;buffer mark 3819 nil ;($v_pkg 20) 3820 nil ;subtype 21 unused 3821 p-store-gvector ;($v_istruct 22) 3822 p-store-ivector ;($v_ratio 23) 3823 p-store-ivector ;($v_complex 24) 3824 nil ;($v_instance 25) ;clos instance 3825 nil ;subtype 26 unused 3826 nil ;subtype 27 unused 3827 nil ;subtype 28 unused 3828 p-store-gvector ;($v_weakh 29) 3829 p-store-gvector ;($v_poolfreelist 30) 3830 p-store-gvector ;($v_nhash 31) 3831 )) 4196 (vtype-vector :bignum #-ccl-68k-target p-store-bignum 4197 #+ccl-68k-target p-store-ivector 4198 #+ccl :badptr #+ccl p-store-ivector 4199 #+ccl :xstr #+ccl p-store-ivector 4200 :ubytev p-store-ivector ;unsigned byte vector 4201 :uwordv p-store-ivector ;unsigned word vector 4202 :floatv p-store-ivector ;float vector 4203 :slongv p-store-ivector ;Signed long vector 4204 :ulongv p-store-ivector ;Unsigned long vector 4205 :bitv #-ccl-68k-target p-store-bit-vector 4206 #+ccl-68k-target p-store-ivector 4207 :sbytev p-store-ivector ;Signed byte vector 4208 :swordv p-store-ivector ;Signed word vector 4209 :sstr p-store-ivector ;simple string 4210 :genv p-store-gvector ;simple general vector 4211 :arrayh #-ccl-68k-target p-store-arrayh ;complex array header 4212 #+ccl-68k-target p-store-gvector 4213 :garrayh p-store-garrayh 4214 :iarrayh p-store-iarrayh 4215 :struct #+ccl p-store-gvector #-ccl p-store-struct ;structure 4216 :istruct p-store-gvector 4217 :ratio #+ccl p-store-ivector ;; ???? 4218 #-ccl p-store-ratio 4219 :complex #+ccl p-store-ivector ;; ???? 4220 #-ccl p-store-gvector 4221 :weakh p-store-gvector 4222 :poolfreelist p-store-g-vector 4223 :nhash #+(or (not ccl) ccl-3) p-store-nhash 4224 #-(or (not ccl) ccl-3) p-store-gvector)) 3832 4225 3833 4226 (defparameter *subtype->uvreffer* 3834 #(nil ; 0 - unused 3835 uvref-unsigned-word ; 1 - $v_bignum 3836 nil ; 2 - $v_macptr - not supported 3837 uvref-unsigned-long ; 3 - $v_badptr 3838 uvref-unsigned-word ; 4 - $v_nlfunv 3839 nil ; 5 - unused 3840 uvref-extended-string ; 6 - $v_xstr - extended string 3841 uvref-unsigned-byte ; 7 - $v_ubytev - unsigned byte vector 3842 uvref-unsigned-word ; 8 - $v_uwordv - unsigned word vector 3843 uvref-dfloat ; 9 - $v_floatv - float vector 3844 uvref-signed-long ; 10 - $v_slongv - Signed long vector 3845 uvref-unsigned-long ; 11 - $v_ulongv - Unsigned long vector 3846 uvref-bit-vector ; 12 - $v_bitv - Bit vector 3847 uvref-signed-byte ; 13 - $v_sbytev - Signed byte vector 3848 uvref-signed-word ; 14 - $v_swordv - Signed word vector 3849 uvref-string ; 15 - $v_sstr - simple string 3850 uvref-genv ; 16 - $v_genv - simple general vector 3851 uvref-genv ; 17 - $v_arrayh - complex array header 3852 uvref-genv ; 18 - $v_struct - structure 3853 nil ; 19 - $v_mark - buffer mark unimplemented 3854 uvref-genv ; 20 - $v_pkg 3855 nil ; 21 - unused 3856 uvref-genv ; 22 - $v_istruct - type in first element 3857 uvref-genv ; 23 - $v_ratio 3858 uvref-genv ; 24 - $v_complex 3859 uvref-genv ; 25 - $v_instance - clos instance 3860 nil ; 26 - unused 3861 nil ; 27 - unused 3862 nil ; 28 - unused 3863 uvref-genv ; 29 - $v_weakh - weak list header 3864 uvref-genv ; 30 - $v_poolfreelist - free pool header 3865 uvref-genv ; 31 - $v_nhash 3866 ; WOOD specific subtypes 3867 uvref-genv ; 32 - $v_area - area descriptor 3868 uvref-genv ; 33 - $v_segment - area segment 3869 uvref-unsigned-byte ; 34 - $v_random-bits - vectors of random bits, e.g. resources 3870 uvref-genv ; 35 - $v_dbheader - database header 3871 nil ; 36 - $v_segment-headers - specially allocated 3872 uvref-genv ; 37 - $v_btree 3873 nil ; 38 - $v_btree-node - specially allocated 3874 uvref-genv ; 39 - $v_class 3875 uvref-genv ; 40 - $v_load-function 3876 uvref-genv ; 41 - $v_pload-barrier 3877 )) 4227 (vtype-vector :bignum uvref-unsigned-word 4228 :badptr uvref-unsigned-long 4229 :nlfunv uvref-unsigned-word 4230 :xstr uvref-extended-string 4231 :ubytev uvref-unsigned-byte 4232 :uwordv uvref-unsigned-word 4233 :floatv uvref-dfloat 4234 :slongv uvref-signed-long 4235 :ulongv uvref-unsigned-long 4236 :bitv uvref-bit-vector 4237 :sbytev uvref-signed-byte 4238 :swordv uvref-signed-word 4239 :sstr uvref-string 4240 :genv uvref-genv 4241 :arrayh uvref-genv 4242 :garrayh uvref-genv 4243 :iarrayh uvref-unsigned-byte 4244 :struct uvref-genv 4245 :pkg uvref-genv 4246 :istruct uvref-genv 4247 :ratio uvref-genv 4248 :complex uvref-genv 4249 :instance uvref-genv 4250 :weakh uvref-genv 4251 :poolfreelist uvref-genv 4252 :nhash uvref-genv 4253 ; WOOD specific subtypes 4254 :area uvref-genv 4255 :segment uvref-genv 4256 :random-bits uvref-unsigned-byte 4257 :dbheader uvref-genv 4258 :btree uvref-genv 4259 :class uvref-genv 4260 :load-function uvref-genv 4261 :pload-barrier uvref-genv)) 3878 4262 3879 4263 (defparameter *subtype->uvsetter* 3880 #(nil ; 0 - unused 3881 uvset-word ; 1 - $v_bignum 3882 nil ; 2 - $v_macptr - not supported 3883 uvset-long ; 3 - $v_badptr 3884 uvset-word ; 4 - $v_nlfunv 3885 nil ; 5 - unused 3886 uvset-extended-string ; 6 - $v_xstr - extended string 3887 uvset-byte ; 7 - $v_ubytev - unsigned byte vector 3888 uvset-word ; 8 - $v_uwordv - unsigned word vector 3889 uvset-dfloat ; 9 - $v_floatv - float vector 3890 uvset-long ; 10 - $v_slongv - Signed long vector 3891 uvset-long ; 11 - $v_ulongv - Unsigned long vector 3892 uvset-bit-vector ; 12 - $v_bitv - Bit vector 3893 uvset-byte ; 13 - $v_sbytev - Signed byte vector 3894 uvset-word ; 14 - $v_swordv - Signed word vector 3895 uvset-string ; 15 - $v_sstr - simple string 3896 uvset-genv ; 16 - $v_genv - simple general vector 3897 uvset-genv ; 17 - $v_arrayh - complex array header 3898 uvset-genv ; 18 - $v_struct - structure 3899 nil ; 19 - $v_mark - buffer mark unimplemented 3900 uvset-genv ; 20 - $v_pkg 3901 nil ; 21 - unused 3902 uvset-genv ; 22 - $v_istruct - type in first element 3903 uvset-genv ; 23 - $v_ratio 3904 uvset-genv ; 24 - $v_complex 3905 uvset-genv ; 25 - $v_instance - clos instance 3906 nil ; 26 - unused 3907 nil ; 27 - unused 3908 nil ; 28 - unused 3909 uvset-genv ; 29 - $v_weakh - weak list header 3910 uvset-genv ; 30 - $v_poolfreelist - free pool header 3911 uvset-genv ; 31 - $v_nhash 3912 ; WOOD specific subtypes 3913 uvset-genv ; 32 - $v_area - area descriptor 3914 uvset-genv ; 33 - $v_segment - area segment 3915 uvset-byte ; 34 - $v_random-bits - vectors of random bits, e.g. resources 3916 uvset-genv ; 35 - $v_dbheader - database header 3917 nil ; 36 - $v_segment-headers - specially allocated 3918 uvset-genv ; 37 - $v_btree 3919 nil ; 38 - $v_btree-node - specially allocated 3920 uvset-genv ; 39 - $v_class 3921 uvset-genv ; 40 - $v_load-function 3922 uvset-genv ; 41 - $v_pload-barrier 3923 )) 4264 (vtype-vector :bignum uvset-word 4265 :badptr uvset-long 4266 :nlfunv uvset-word 4267 :xstr uvset-extended-string 4268 :ubytev uvset-byte 4269 :uwordv uvset-word 4270 :floatv uvset-dfloat 4271 :slongv uvset-long 4272 :ulongv uvset-long 4273 :bitv uvset-bit-vector 4274 :sbytev uvset-byte 4275 :swordv uvset-word 4276 :sstr uvset-string 4277 :genv uvset-genv 4278 :arrayh uvset-genv 4279 :garrayh uvset-genv 4280 :iarrayh uvset-byte 4281 :struct uvset-genv 4282 :pkg uvset-genv 4283 :istruct uvset-genv 4284 :ratio uvset-genv 4285 :complex uvset-genv 4286 :instance uvset-genv 4287 :weakh uvset-genv 4288 :poolfreelist uvset-genv 4289 :nhash uvset-genv 4290 ; WOOD specific subtypes 4291 :area uvset-genv 4292 :segment uvset-genv 4293 :random-bits uvset-byte 4294 :dbheader uvset-genv 4295 :btree uvset-genv 4296 :class uvset-genv 4297 :load-function uvset-genv 4298 :pload-barrier uvset-genv)) 3924 4299 3925 4300 (defparameter *subtype-initial-element* 3926 #(nil ; 0 - unused 3927 nil ; 1 - $v_bignum 3928 nil ; 2 - $v_macptr not implemented 3929 nil ; 3 - $v_badptr not implemented 3930 nil ; 4 - $v_nlfunv 3931 nil ; 5 - unused 3932 nil ; 6 - $v_xstr - extended string 3933 nil ; 7 - $v_ubytev - unsigned byte vector 3934 nil ; 8 - $v_uwordv - unsigned word vector 3935 0 ; 9 - $v_floatv - float vector 3936 nil ; 10 - $v_slongv - Signed long vector 3937 nil ; 11 - $v_ulongv - Unsigned long vector 3938 nil ; 12 - $v_bitv - Bit vector 3939 nil ; 13 - $v_sbytev - Signed byte vector 3940 nil ; 14 - $v_swordv - Signed word vector 3941 nil ; 15 - $v_sstr - simple string 3942 #.$pheap-nil ; 16 - $v_genv - simple general vector 3943 #.$pheap-nil ; 17 - $v_arrayh - complex array header 3944 #.$pheap-nil ; 18 - $v_struct - structure 3945 nil ; 19 - $v_mark - buffer mark unimplemented 3946 #.$pheap-nil ; 20 - $v_pkg 3947 nil ; 21 - unused 3948 #.$pheap-nil ; 22 - $v_istruct - type in first element 3949 0 ; 23 - $v_ratio 3950 0 ; 24 - $v_complex 3951 #.$pheap-nil ; 25 - $v_instance - clos instance 3952 nil ; 26 - unused 3953 nil ; 27 - unused 3954 nil ; 28 - unused 3955 #.$pheap-nil ; 29 - $v_weakh - weak list header 3956 #.$pheap-nil ; 30 - $v_poolfreelist - free pool header 3957 nil ; 31 - $v_nhash unused 3958 #.$pheap-nil ; 32 - $v_area - area descriptor 3959 #.$pheap-nil ; 33 - $v_segment - area segment 3960 nil ; 34 - $v_random-bits - vectors of random bits, e.g. resources 3961 #.$pheap-nil ; 35 - $v_dbheader - database header 3962 nil ; 36 - $v_segment-headers - specially allocated 3963 #.$pheap-nil ; 37 - $v_btree 3964 nil ; 38 - $v_btree-node - specially allocated 3965 #.$pheap-nil ; 39 - $v_class 3966 #.$pheap-nil ; 40 - $v_load-function 3967 #.$pheap-nil ; 41 - $v_pload-barrier 3968 )) 4301 (vtype-vector :floatv 0 4302 :genv #.$pheap-nil 4303 :arrayh #.$pheap-nil 4304 :garrayh #.$pheap-nil 4305 :struct #.$pheap-nil 4306 :pkg #.$pheap-nil 4307 :istruct #.$pheap-nil 4308 :ratio 0 4309 :complex 0 4310 :instance #.$pheap-nil 4311 :weakh #.$pheap-nil 4312 :poolfreelist #.$pheap-nil 4313 :area #.$pheap-nil 4314 :segment #.$pheap-nil 4315 :dbheader #.$pheap-nil 4316 :btree #.$pheap-nil 4317 :class #.$pheap-nil 4318 :load-function #.$pheap-nil 4319 :pload-barrier #.$pheap-nil)) 3969 4320 3970 4321 #+ppc-target … … 4036 4387 4037 4388 4038 (defun init-temp-pheap ( )4389 (defun init-temp-pheap (&optional inspect?) 4039 4390 (declare (special pheap dc)) 4040 4391 (when (boundp 'pheap) … … 4044 4395 (setq pheap (open-pheap "temp.pheap") 4045 4396 dc (pheap-disk-cache pheap)) 4046 (dolist (w (windows :class 'inspector::inspector-window)) 4047 (window-close w)) 4048 (inspect dc)) 4049 4397 #+ccl (dolist (w (windows :class 'inspector::inspector-window)) 4398 (window-close w)) 4399 (when inspect? (inspect dc))) 4400 4401 4402 (init-temp-pheap) 4050 4403 (setq p $pheap-nil) 4051 4404 4052 (time 4053 (dotimes (i 200) 4054 (setq p (dc-cons dc i p t nil)))) 4405 (defun test-cons (count &optional (p $pheap-nil)) 4406 (declare (special dc)) 4407 (dotimes (i count) 4408 (setq p (dc-cons dc i p t nil)))) 4409 4410 (time (test-cons 20000)) 4055 4411 4056 4412 (time -
lw-branch/q.lisp
r3 r6 1 ;;;-*- Mode: Lisp; Package: CCL-*-1 ;;;-*- Mode: Lisp; Package: Wood -*- 2 2 3 3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 6 6 ;; A simple fifo queue. Why isn't this part of Common Lisp 7 7 ;; 8 ;; Portions Copyright © 2006 Clozure Associates 8 9 ;; Copyright © 1996 Digitool, Inc. 9 10 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 20 21 ;; Modification History 21 22 ;; 23 ;; 02/01/06 gz LispWorks port 22 24 ;; ------------- 0.96 23 25 ;; 08/27/96 bill Added copyright and mod history comments 24 26 ;; 25 27 26 (in-package :ccl)28 (in-package #+ccl :ccl #-ccl :wood) 27 29 28 30 (export '(make-q enq deq q-empty-p)) 29 31 30 (require "LISPEQU") ; %cons-pool, pool.data32 #+ccl (require "LISPEQU") ; %cons-pool, pool.data 31 33 32 34 (defstruct q … … 41 43 42 44 (defconstant $q-buf-size 512) 45 #+Lispworks (defconstant $max-num-q-bufs 20) 43 46 44 (defvar *q-bufs* (%cons-pool)) 47 (defvar *q-bufs* 48 #+ccl (%cons-pool) 49 #+LispWorks (let ((arr (make-array $max-num-q-bufs))) 50 (hcl:set-array-weak arr t) 51 arr)) 45 52 46 53 (defun make-q-buf () 47 54 (without-interrupts 48 (let ((buf (pool.data *q-bufs*))) 49 (if buf 50 (progn 51 (setf (pool.data *q-bufs*) (svref buf 0)) 52 (dotimes (i $q-buf-size) 53 (setf (svref buf i) nil)) 54 buf) 55 (make-array $q-buf-size))))) 55 #+ccl 56 (let ((buf (pool.data *q-bufs*))) 57 (if buf 58 (progn 59 (setf (pool.data *q-bufs*) (svref buf 0)) 60 (dotimes (i $q-buf-size) 61 (setf (svref buf i) nil)) 62 buf) 63 (make-array $q-buf-size))) 64 #+LispWorks 65 (let ((pos (position-if-not #'null *q-bufs*))) 66 (if pos 67 (let ((buf (aref *q-bufs* pos))) 68 (setf (aref *q-bufs* pos) nil) 69 (fill buf nil) 70 buf) 71 (make-array $q-buf-size))))) 56 72 57 73 (defun free-q-buf (buf) 58 74 (without-interrupts 59 (setf (svref buf 0) (pool.data *q-bufs*) 60 (pool.data *q-bufs*) buf) 61 nil)) 75 #+ccl 76 (setf (svref buf 0) (pool.data *q-bufs*) 77 (pool.data *q-bufs*) buf) 78 #+LispWorks 79 (let ((pos (position-if #'null *q-bufs*))) 80 (when pos 81 (setf (aref *q-bufs* pos) buf))) 82 nil)) 62 83 63 84 (defun enq (q elt) -
lw-branch/wood-gc.lisp
r3 r6 443 443 (loop 444 444 (when (< bytes-to-go 512) 445 (load-byte -array input-dc from bytes-to-go string 0 t)446 (store-byte -array string output-dc to bytes-to-go 0 t)445 (load-bytes-to-string input-dc from bytes-to-go string) 446 (store-bytes-from-string string output-dc to bytes-to-go) 447 447 (return)) 448 (load-byte -array input-dc from 512 string 0 t)449 (store-byte -array string output-dc to 512 0 t)448 (load-bytes-to-string input-dc from 512 string) 449 (store-bytes-from-string string output-dc to 512) 450 450 (setq from (addr+ input-dc from 512)) 451 451 (setq to (addr+ output-dc to 512)) … … 459 459 460 460 (defparameter *subtype-node-p* 461 #(nil ; 0 - unused 462 nil ; 1 - $v_bignum 463 nil ; 2 - $v_macptr not implemented 464 nil ; 3 - $v_badptr not implemented 465 t ; 4 - $v_nlfunv 466 nil ; 5 - unused 467 nil ; 6 - unused 468 nil ; 7 - $v_ubytev - unsigned byte vector 469 nil ; 8 - $v_uwordv - unsigned word vector 470 nil ; 9 - $v_floatv - float vector 471 nil ; 10 - $v_slongv - Signed long vector 472 nil ; 11 - $v_ulongv - Unsigned long vector 473 nil ; 12 - $v_bitv - Bit vector 474 nil ; 13 - $v_sbytev - Signed byte vector 475 nil ; 14 - $v_swordv - Signed word vector 476 nil ; 15 - $v_sstr - simple string 477 t ; 16 - $v_genv - simple general vector 478 t ; 17 - $v_arrayh - complex array header 479 t ; 18 - $v_struct - structure 480 t ; 19 - $v_mark - buffer mark unimplemented 481 t ; 20 - $v_pkg 482 nil ; 21 - unused 483 t ; 22 - $v_istruct - type in first element 484 t ; 23 - $v_ratio 485 t ; 24 - $v_complex 486 t ; 25 - $v_instance - clos instance 487 nil ; 26 - unused 488 nil ; 27 - unused 489 nil ; 28 - unused 490 t ; 29 - $v_weakh - weak list header 491 t ; 30 - $v_poolfreelist - free pool header 492 t ; 31 - $v_nhash unused 493 t ; 32 - $v_area - area descriptor 494 t ; 33 - $v_segment - area segment 495 nil ; 34 - $v_random-bits - vectors of random bits, e.g. resources 496 t ; 35 - $v_dbheader - database header 497 nil ; 36 - $v_segment-headers - specially allocated 498 t ; 37 - $v_btree 499 nil ; 38 - $v_btree-node - specially allocated 500 t ; 39 - $v_class 501 t ; 40 - $v_load-function 502 )) 461 (vtype-vector :nlfunv t 462 :genv t 463 :arrayh t 464 :struct t 465 :pkg t 466 :istruct t 467 :ratio t 468 :complex t 469 :instance t 470 :garrayh t 471 :weakh t 472 :poolfreelist t 473 :nhash t 474 :area t 475 :segment t 476 :dbheader t 477 :btree t 478 :class t 479 :load-function t)) 503 480 504 481 (defparameter *subtype-special-copy-function* -
lw-branch/wood.lisp
r3 r6 8 8 ;; in the file "load-wood.lisp" 9 9 ;; 10 ;; Portions Copyright © 2006 Clozure Associates 10 11 ;; Copyright © 1996 Digitool, Inc. 11 12 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 23 24 ;; Modification History 24 25 ;; 26 ;; 02/01/06 gz LispWorks port 25 27 ;; ------------- 0.961 26 28 ;; 09/20/96 bill resignal the error in the handler-case if not a wrong fasl version error … … 40 42 (in-package :cl-user) 41 43 44 #+ccl 42 45 (labels ((load-it () 43 46 (let* ((path (or *load-pathname* *loading-file-source-file*)) … … 47 50 :directory (pathname-directory path) 48 51 :name "load-wood" 49 :defaults nil)))52 :defaults nil))) 50 53 (handler-case 51 54 (compile-load load-wood-path :verbose t) … … 55 58 (progn 56 59 (format t "~&;Deleting FASL file from other MCL version...") 57 (delete-file (merge-pathnames load-wood-path ccl::*.fasl-pathname*)) 60 (delete-file (merge-pathnames load-wood-path 61 ccl::*.fasl-pathname*)) 58 62 (return-from load-it (load-it))) 59 63 (error condition))))))) 60 64 (load-it)) 61 65 66 67 #+LispWorks 68 (labels ((load-it () 69 (let* ((path (or *load-pathname* 70 dspec:*source-pathname* 71 system:*current-pathname*)) 72 (load-wood-path 73 (make-pathname :host (pathname-host path) 74 :device (pathname-device path) 75 :directory (pathname-directory path) 76 :name "load-wood"))) 77 (compile-file load-wood-path :verbose t :load t)))) 78 (load-it)) 79 80 62 81 63 82 ; Wood package is created by "load-wood.lisp" -
lw-branch/woodequ.lisp
r3 r6 7 7 ;; Largely copied from "ccl:library;lispequ.lisp" 8 8 ;; 9 ;; Portions Copyright © 2006 Clozure Associates 9 10 ;; Copyright © 1996 Digitool, Inc. 10 11 ;; Copyright © 1992-1995 Apple Computer, Inc. … … 22 23 ;; Modification History 23 24 ;; 25 ;; 02/01/06 gz LispWorks port 24 26 ;; -------------- 0.96 25 27 ;; -------------- 0.95 … … 55 57 `(logand ,pointer -8)) 56 58 59 #+ccl (progn 57 60 (defconstant $t_fixnum 0) 58 61 (defconstant $t_vector 1) … … 63 66 (defconstant $t_lfun 6) 64 67 (defconstant $t_imm 7) 68 69 (defconstant $dfloat_size 8) 70 71 (defmacro tag-vector (&key fixnum vector symbol dfloat cons sfloat lfun imm) 72 (vector fixnum vector symbol dfloat cons sfloat lfun imm)) 73 74 ) ;#+ccl 75 76 #+LispWorks (progn 77 (defconstant $t_pos_fixnum 0) 78 (defconstant $t_vector 1) 79 (defconstant $t_symbol 2) 80 (defconstant $t_dfloat 3) 81 (defconstant $t_cons 4) 82 (defconstant $t_neg_fixnum 5) 83 (defconstant $t_char 6) 84 (defconstant $t_imm 7) 85 86 (defconstant $undefined-imm 0) 87 88 (defmacro tag-vector (&key pos-fixnum vector symbol dfloat cons neg-fixnum char imm) 89 (vector pos-fixnum vector symbol dfloat cons neg-fixnum char imm)) 90 91 ) ;#+LispWorks 92 65 93 66 94 ; Non-cons cells have a header long-word for the garbage collector. … … 91 119 (defconstant $v_nlfunv 4) ; Lisp FUNction vector 92 120 ;subtype 5 unused 121 (defconstant $v_min_arr 6) 93 122 (defconstant $v_xstr 6) ;16-bit character vector 94 (defconstant $v_min_arr 7)95 123 (defconstant $v_ubytev 7) ;unsigned byte vector 96 124 (defconstant $v_uwordv 8) ;unsigned word vector … … 112 140 (defconstant $v_complex 24) 113 141 (defconstant $v_instance 25) ;clos instance 114 ; subtypes 26, 27, 28 unused. 142 ; subtypes 26, 27, 28 unused in ccl 143 #+LispWorks (defconstant $v_garrayh 26) 144 #+LispWorks (defconstant $v_iarrayh 27) 115 145 (defconstant $v_weakh 29) 116 146 (defconstant $v_poolfreelist 30) … … 136 166 137 167 (defconstant $vnodebit 5) ; set for arrays containing pointers 138 (defconstant $vnode ( lsh 1 $vnodebit))168 (defconstant $vnode (ash 1 $vnodebit)) 139 169 140 170 ; NIL is tagged as a cons with and address of 0 141 171 (defconstant $pheap-nil $t_cons) 172 173 (defmacro vtype-vector (&key unused 174 (bignum unused) (badptr unused) (nlfunv unused) 175 (xstr unused) (ubytev unused) (uwordv unused) 176 (floatv unused) (slongv unused) (ulongv unused) 177 (bitv unused) (sbytev unused) (swordv unused) 178 (sstr unused) (genv unused) (arrayh unused) 179 (struct unused) (pkg unused) (istruct unused) 180 (ratio unused) (complex unused) (instance unused) 181 (weakh unused) (poolfreelist unused) (nhash unused) 182 ;; Simple-arrays other than special vectors above 183 (garrayh unused) (iarrayh unused) 184 ;; internal subtypes 185 area segment random-bits dbheader segment-headers 186 btree btree-node class load-function pload-barrier) 187 (vector unused ; 0 - unused 188 bignum ; 1 - $v_bignum 189 unused ; 2 - $v_macptr - not supported 190 badptr ; 3 - $v_badptr 191 nlfunv ; 4 - $v_nlfunv 192 unused ; 5 - unused 193 xstr ; 6 - $v_xstr - extended string 194 ubytev ; 7 - $v_ubytev - unsigned byte vector 195 uwordv ; 8 - $v_uwordv - unsigned word vector 196 floatv ; 9 - $v_floatv - float vector 197 slongv ; 10 - $v_slongv - Signed long vector 198 ulongv ; 11 - $v_ulongv - Unsigned long vector 199 bitv ; 12 - $v_bitv - Bit vector (handled specially) 200 sbytev ; 13 - $v_sbytev - Signed byte vector 201 swordv ; 14 - $v_swordv - Signed word vector 202 sstr ; 15 - $v_sstr - simple string 203 genv ; 16 - $v_genv - simple general vector 204 arrayh ; 17 - $v_arrayh - complex array header 205 struct ; 18 - $v_struct - structure 206 unused ; 19 - $v_mark - buffer mark unimplemented 207 pkg ; 20 - $v_pkg 208 unused ; 21 - unused 209 istruct ; 22 - $v_istruct - type in first element 210 ratio ; 23 - $v_ratio