storage-types.lisp 42 KB
Newer Older
1 2
;;;;------------------------------------------------------------------
;;;; 
3
;;;;    Copyright (C) 2000-2005,
4
;;;;    Department of Computer Science, University of Tromso, Norway
5 6 7 8 9 10 11
;;;; 
;;;; Filename:      storage-types.lisp
;;;; Description:   Physical storage structures for Movitz objects.
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Sun Oct 22 00:22:43 2000
;;;; Distribution:  See the accompanying file COPYING.
;;;;                
12
;;;; $Id: storage-types.lisp,v 1.56 2006/04/10 11:47:41 ffjeld Exp $
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
;;;;                
;;;;------------------------------------------------------------------

(in-package movitz)

(define-unsigned lu64 8 :little-endian)

(define-bitfield segment-descriptor (lu64)
  (((:numeric limit0 16 0))
   ((:numeric limit1 4 48))
   ((:numeric base0 24 16))
   ((:numeric base1 8 56))
   ((:numeric type 4 40))
   ((:numeric dpl 2 45))
   ((:bits)
    s 44
    p 47
    avl 52
    reserved 53
    d/b 54
    g 55)))

(defun make-segment-descriptor (&key (limit 0) (base 0) (type 0) (dpl 0) (flags nil))
  (check-type limit (unsigned-byte 20))
  (check-type base (unsigned-byte 32))
  `((limit0 . ,(ldb (byte 16 0) limit))
    (limit1 . ,(ldb (byte 4 16) limit))
    (base0  . ,(ldb (byte 24 0) base))
    (base1  . ,(ldb (byte 8 24) base))
    (type   . ,type)
    (dpl    . ,dpl)
    ,@flags))

(defmacro with-image-stream-position-remembered (opts &body body)
  (declare (ignore opts))
  (let ((v (gensym)))
    `(let ((,v (file-position (image-stream *image*))))
       (unwind-protect (progn ,@body)
	 (file-position (image-stream *image*) ,v)))))

(define-enum other-type-byte (u8)
54
  :fixnum 0
55 56 57 58
  :even-fixnum 0
  :odd-fixnum 4
  :cons 1
  :character 2
59 60
  :tag0 0
  :tag1 1
61 62 63
  :tag2 2
  :tag3 3				; unused
  :tag4 4
64 65 66
  :tag5 5
  :tag6 6
  :tag7 7
67 68 69 70 71
  ;; :immediate 4
  :null 5
  :other 6
  :symbol 7
  
72
  :basic-vector #x22
73
  :defstruct #x2a
74
  :funobj #x3a
75
  :bignum #x4a
76 77
  :ratio #x52
  :complex #x5a
78 79
  :std-instance #x40
  :run-time-context #x50
80
  :illegal #x13
81
  :infant-object #x23
82 83 84 85
  :basic-restart #x32
  )

(defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum))
86 87
(defparameter +scan-skip-word+ #x00000003)

88 89 90
(defun tag (type &optional (wide-tag 0))
  (logior (bt:enum-value 'other-type-byte type)
	  (ash wide-tag 8)))
91 92

(defun tag-name (number)
93 94
  (find number '(:even-fixnum :odd-fixnum :cons :character :null :other :symbol)
	:key 'tag))
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152

(defun extract-tag (word)
  (tag-name (ldb (byte 3 0) word)))

(defun extract-pointer (word)
  (logand word #xfffffff8))

(defun slot-map (type &optional (offset 0))
  (let ((slots (binary-record-slot-names type)))
    (loop for slot in slots
	as o = (- (bt:slot-offset type slot) offset)
	collect (list (intern (symbol-name slot) :muerte)
		      (intern (symbol-name (binary-slot-type type slot)) :muerte)
		      (truncate o 4)
		      (rem o 4)))))

(define-unsigned word 4 :little-endian)
(define-unsigned code-vector-word 4 :little-endian) ; A word that points to a code-vector, +2
(define-unsigned code-pointer 4 :little-endian) ; A pointer anywhere, pointing to code.

(defclass movitz-object ()
  ((browsed-slots
    :initarg :browser-properties
    :initform nil
    :accessor movitz-object-browser-properties)))

(defclass movitz-immediate-object (movitz-object) ())
(defclass movitz-heap-object (movitz-object)
  ((word
    :accessor movitz-heap-object-word)))
(defclass movitz-heap-object-other (movitz-heap-object) ())

(defmethod movitz-object-offset ((obj movitz-heap-object-other)) 6)
(defmethod movitz-storage-alignment ((obj movitz-heap-object)) 8)
(defmethod movitz-storage-alignment-offset ((obj movitz-heap-object)) 0)

;;;

(defgeneric movitz-references (obj)
  (:documentation "Return the objects referenced by OBJ."))

(defmethod movitz-references (obj)
  (mapcar #'(lambda (slot)
	      (slot-value obj slot))
	  (binary-record-slot-names (find-binary-type (type-of obj)))))


(defmethod movitz-intern ((obj movitz-heap-object) &optional type)
  (declare (ignore type))
  (image-intern-object *image* obj))

(defmethod movitz-intern ((obj movitz-immediate-object) &optional type)
  (declare (ignore type))
  (movitz-immediate-value obj))

(defun movitz-read-and-intern (expr type)
  (ecase type
    (word
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
153
     (cond
154 155 156
      ((typep expr 'movitz-object)
       (movitz-intern expr))
      (t (movitz-intern (movitz-read expr)))))
157 158 159 160 161
    (code-vector-word
     (movitz-intern-code-vector expr))))

(defmethod update-movitz-object ((obj movitz-heap-object) lisp-obj)
  (declare (ignore lisp-obj))
162
  (break "Don't know how to update ~W." obj))
163 164 165 166 167 168 169 170

(defmethod update-movitz-object ((obj movitz-immediate-object) lisp-obj)
  (declare (ignore lisp-obj))
  (values))
  
;;; Fixnums

(eval-when (:compile-toplevel :execute :load-toplevel)
171 172 173 174 175 176
  (defparameter +movitz-fixnum-bits+ 30)
  (defparameter +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
  (defparameter +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
  (defparameter +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
  (defparameter +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
  (defparameter +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))
177

178 179
  (defparameter +object-pointer-shift+ 0)
  (defparameter +other-type-offset+ (- -6 +object-pointer-shift+)))
180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266

(defun fixnum-integer (word)
  "For a Movitz word, that must be a fixnum, return the corresponding
integer (native lisp) value."
  (assert (member (extract-tag word) +fixnum-tags+) (word)
    "The word ~W is not a fixnum." word)
  (let ((x (ldb (byte (1- +movitz-fixnum-bits+)
		      (- 32 +movitz-fixnum-bits+))
		word)))
    (if (logbitp 31 word)
	(- (1+ (logxor x +movitz-most-positive-fixnum+)))
      x)))

(define-binary-class movitz-fixnum (movitz-immediate-object)
  ((value :binary-type word
	  :initarg :value
	  :reader movitz-fixnum-value)))

(defmethod print-object ((object movitz-fixnum) stream)
  (print-unreadable-object (object stream :type t)
    (write (movitz-fixnum-value object) :stream stream))
  object)

(defun make-movitz-fixnum (value)
  (check-type value (signed-byte #.+movitz-fixnum-bits+))
  (make-instance 'movitz-fixnum :value value))

(defmethod movitz-immediate-value ((obj movitz-fixnum))
  (dpb (movitz-fixnum-value obj)
       (byte +movitz-fixnum-bits+ (- 32 +movitz-fixnum-bits+))
       0))

(defclass movitz-unboxed-integer (movitz-immediate-object) ())
(defclass movitz-unboxed-integer-u8 (movitz-unboxed-integer) ())
(defclass movitz-unboxed-integer-u32 (movitz-unboxed-integer) ())

;;; Characters

(define-binary-class movitz-character (movitz-immediate-object)
  ((char :binary-type word
	 :initarg :char
	 :type character
	 :reader movitz-char)))

(defun make-movitz-character (char)
  (check-type char character)
  (make-instance 'movitz-character :char char))

(defmethod movitz-immediate-value ((obj movitz-character))
  (dpb (char-code (movitz-char obj))
       (byte 8 8)
       (tag :character)))

(defmethod print-object ((x movitz-character) stream)
  (print-unreadable-object (x stream)
    (format stream "MOVITZ-CHARACTER: ~S" (movitz-char x))))

(defun movitz-eql (x y)
  (if (and (typep x 'movitz-immediate-object)
	   (typep y 'movitz-immediate-object))
      (= (movitz-immediate-value x)
	 (movitz-immediate-value y))
    (eq x y)))

;;; Code element

(define-binary-class movitz-code (movitz-immediate-object)
  ((byte :binary-type (define-unsigned code 1)
	 :reader movitz-code-byte
	 :initarg byte)))

(defun make-movitz-code (byte)
  (make-instance 'movitz-code 'byte byte))    

;;; Conses

(define-binary-class movitz-cons (movitz-heap-object)
  ((car :binary-type word
	:map-binary-write 'movitz-intern
	:map-binary-read-delayed 'movitz-word
	:initarg :car
	:accessor movitz-car)
   (cdr :binary-type word
	:map-binary-write 'movitz-intern
	:map-binary-read-delayed 'movitz-word
	:initarg :cdr
	:accessor movitz-cdr))
267
  (:slot-align car #.(- -1 +object-pointer-shift+)))
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283

(defmethod movitz-object-offset ((obj movitz-cons)) 1)

(defmethod update-movitz-object ((movitz-cons movitz-cons) (lisp-cons cons))
  (setf (movitz-car movitz-cons) (movitz-read (car lisp-cons))
	(movitz-cdr movitz-cons) (movitz-read (cdr lisp-cons))))

(defun make-movitz-cons (car cdr)
  (check-type car movitz-object)
  (check-type cdr movitz-object)
  (make-instance 'movitz-cons
    :car car
    :cdr cdr))

(defun print-cons (ic stream)
  (typecase (movitz-cdr ic)
284
    (movitz-null (format stream "~A" (movitz-car ic)))
285 286 287 288 289 290
    (movitz-cons (format stream "~A " (movitz-car ic)))
    (t (format stream "~A . ~A" (movitz-car ic) (movitz-cdr ic)))))

(defun movitz-list-length (x)
  (etypecase x
    (list (list-length x))
291
    (movitz-null 0)
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332
    (movitz-cons
     (flet ((movitz-endp (x) (eq x *movitz-nil*)))
       (do ((n 0 (+ n 2))		;Counter.
	    (fast x (movitz-cdr (movitz-cdr fast))) ;Fast pointer: leaps by 2.
	    (slow x (movitz-cdr slow)))	;Slow pointer: leaps by 1.
	   (nil)
	 ;; If fast pointer hits the end, return the count.
	 (when (movitz-endp fast) (return n))
	 (when (movitz-endp (movitz-cdr fast)) (return (+ n 1)))
	 ;; If fast pointer eventually equals slow pointer,
	 ;;  then we must be stuck in a circular list.
	 ;; (A deeper property is the converse: if we are
	 ;;  stuck in a circular list, then eventually the
	 ;;  fast pointer will equal the slow pointer.
	 ;;  That fact justifies this implementation.)
	 (when (and (eq fast slow) (> n 0))
	   (warn "Circular list: ~S" x)
	   (return nil)))))))

(defmethod print-object ((obj movitz-cons) stream)
  (format stream "#&(")
  (loop for ic = obj then (movitz-cdr ic) as i from 0 to (or *print-length* 100)
      while (typep ic 'movitz-cons)
      do (print-cons ic stream)
      finally (if (>= i 16)
		  (format stream "...)")
		(format stream ")")))
  obj)

(defun movitz-nthcdr (n movitz-list)
  (if (zerop n)
      movitz-list
    (movitz-nthcdr (1- n) (movitz-cdr movitz-list))))

(defun (setf movitz-last-cdr) (value movitz-list)
  (if (not (typep (movitz-cdr movitz-list) 'movitz-cons))
      (setf (movitz-cdr movitz-list) value)
    (setf (movitz-last-cdr (movitz-cdr movitz-list)) value)))

;;; movitz-vectors

333
(define-binary-class movitz-basic-vector (movitz-heap-object-other)
334
  ((type
335 336
    :binary-type other-type-byte
    :reader movitz-vector-type
337
    :initform :basic-vector)
338 339 340 341 342 343 344
   (element-type
    :binary-type (define-enum movitz-vector-element-type (u8)
		   :any-t 0
		   :character 1
		   :u8 2
		   :u16 3
		   :u32 4
345
		   :bit 5
346 347
		   :code 6
		   :indirects 7)
348 349
    :initarg :element-type
    :reader movitz-vector-element-type)
350
   (fill-pointer
351
    :binary-type lu16
352
    :initarg :fill-pointer
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
    :accessor movitz-vector-fill-pointer
    :map-binary-write (lambda (x &optional type)
			(declare (ignore type))
			(check-type x (unsigned-byte 14))
			(* x 4))
    :map-binary-read (lambda (x &optional type)
		       (declare (ignore type))
		       (assert (zerop (mod x 4)))
		       (truncate x 4)))
   (num-elements
    :binary-type word
    :initarg :num-elements
    :reader movitz-vector-num-elements
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word-and-print)
368 369 370 371
   (data
    :binary-lisp-type :label)		; data follows physically here
   (symbolic-data
    :initarg :symbolic-data
372
    :initform nil
373
    :accessor movitz-vector-symbolic-data))
374
  (:slot-align type #.+other-type-offset+))
375

376 377 378 379 380 381 382 383 384
(defmethod print-object ((object movitz-basic-vector) stream)
  (cond
   ((eq :character (movitz-vector-element-type object))
    (print-unreadable-object (object stream :type t :identity nil)
      (write (map 'string #'identity (movitz-vector-symbolic-data object))
	     :stream stream))
    object)
   (t (call-next-method))))
    
385 386 387 388 389
(defun basic-vector-type-tag (element-type)
  (dpb (enum-value 'movitz-vector-element-type element-type)
       (byte 8 8)
       (enum-value 'other-type-byte :basic-vector)))

390
(defun movitz-type-word-size (type)
391
  "What's the size of TYPE in words?"
392
  (truncate (sizeof (intern (symbol-name type) :movitz)) 4))
393 394 395 396 397 398 399

(defun movitz-svref (vector index)
  (elt (movitz-vector-symbolic-data vector) index))

(defun movitz-vector-element-type-size (element-type)
  (ecase element-type
    ((:any-t :u32) 32)
400
    ((:character :u8 :code) 8)
401 402 403
    (:u16 16)
    (:bit 1)))

404 405 406
(defmethod update-movitz-object ((movitz-vector movitz-basic-vector) (vector vector))
  (when (eq :any-t (movitz-vector-element-type movitz-vector))
    (loop for i from 0 below (length vector)
407 408
	do (setf (aref (movitz-vector-symbolic-data movitz-vector) i)
	     (movitz-read (aref vector i)))))
409 410 411 412 413
  (values))

(defmethod write-binary-record ((obj movitz-basic-vector) stream)
  (flet ((write-element (type stream data)
	   (ecase type
414
	     ((:u8 :code)(write-binary 'u8 stream data))
415 416 417
	     (:u16       (write-binary 'u16 stream data))
	     (:u32       (write-binary 'u32 stream data))
	     (:character (write-binary 'char8 stream data))
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435
	     (:any-t     (write-binary 'word stream (movitz-read-and-intern data 'word))))))
    (+ (call-next-method)		; header
       (etypecase (movitz-vector-symbolic-data obj)
	 (list 
	  (loop for data in (movitz-vector-symbolic-data obj)
	      with type = (movitz-vector-element-type obj)
	      summing (write-element type stream data)))
	 (vector
	  (loop for data across (movitz-vector-symbolic-data obj)
	      with type = (movitz-vector-element-type obj)
	      summing (write-element type stream data)))))))

(defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys)
  (let ((object (call-next-method)))
    (setf (movitz-vector-symbolic-data object)
      (loop for i from 1 to (movitz-vector-num-elements object)
	  collecting
	    (ecase (movitz-vector-element-type object)
436
	      ((:u8 :code)(read-binary 'u8 stream))
437 438 439 440 441 442 443 444 445 446 447 448 449 450
	      (:u16       (read-binary 'u16 stream))
	      (:u32       (read-binary 'u32 stream))
	      (:character (read-binary 'char8 stream))
	      (:any-t     (let ((word (read-binary 'word stream)))
			    (with-image-stream-position-remembered ()
			      (movitz-word word)))))))
    object))

(defmethod sizeof ((object movitz-basic-vector))
  (+ (call-next-method)
     (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type))
		 (slot-value object 'num-elements))
	      8)))

451
(defun movitz-vector-upgrade-type (type)
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
  (cond
   ((eq type 'code)
    (values :code 0))
   ((subtypep type '(unsigned-byte 8))
    (values :u8 0))
   ((subtypep type '(unsigned-byte 16))
    (values :u16 0))
   ((subtypep type '(unsigned-byte 32))
    (values :u32 0))
   ((subtypep type 'character)
    (values :character #\null))
   (t (values :any-t nil)))
  #+ignore (case type
	     (movitz-unboxed-integer-u8
	      (values :u8 0))
	     (movitz-unboxed-integer-u32
	      (values :u32 0))
	     (movitz-character
	      (values :character #\null))
	     (movitz-code
	      (values :code 0))
	     (t (values :any-t nil))))

(defun make-movitz-vector (size &key (element-type t)
476 477 478 479 480 481
				     (initial-contents nil)
				     (initial-element *movitz-nil* initial-element-p)
				     (alignment 8)
				     (alignment-offset 0)
				     (flags nil)
				     fill-pointer)
482 483 484
  (assert (or (null initial-contents)
	      (= size (length initial-contents))) (size initial-contents)
    "The initial-contents must be the same length as SIZE.")
485 486 487 488 489 490 491
;;;  (assert (subtypep element-type 'movitz-object) ()
;;;    "ELEMENT-TYPE must be a subtype of MOVITZ-OBJECT.")
;;;  (assert (or initial-contents
;;;	      (not initial-element-p)
;;;	      (typep initial-element element-type)) ()
;;;    "INITIAL-ELEMENT's type ~A is not of ELEMENT-TYPE ~A."
;;;    (type-of initial-element) element-type)
492 493 494 495 496 497 498 499 500 501 502 503 504
  (assert (and (>= (log alignment 2) 3)
	       (zerop (rem (log alignment 2) 1)))
      (alignment)
    "Illegal alignment: ~A." alignment)
  (multiple-value-bind (et default-element)
      (movitz-vector-upgrade-type element-type)
    (when initial-element-p
      (assert (not initial-contents) ()
	"Can't provide both initial-element and initial-contents."))
    (unless initial-contents
      (setf initial-contents
	(make-array size :initial-element (or (and initial-element-p initial-element)
					      default-element))))
505 506 507 508 509 510 511
    (assert (member et '(:any-t :character :u8 :u32 :code)))
    (when flags (break "flags: ~S" flags))
    (when (and alignment-offset (plusp alignment-offset))
      (break "alignment: ~S" alignment-offset))
    (make-instance 'movitz-basic-vector
      :element-type et
      :num-elements size
512 513 514 515
      :symbolic-data (case et
		       (:any-t
			(map 'vector #'movitz-read initial-contents))
		       (t initial-contents))
516 517 518 519 520 521
      :fill-pointer (cond
		     ((not (typep size '(unsigned-byte 14)))
		      0)
		     ((integerp fill-pointer)
		      fill-pointer)
		     (t size)))))
522 523 524

(defun make-movitz-string (string)
  (make-movitz-vector (length string)
525
		   :element-type 'character
526 527 528
		   :initial-contents (map 'list #'identity string)))

(defun movitz-stringp (x)
529
  (and (typep x '(or movitz-basic-vector))
530 531 532 533 534
       (eq :character (movitz-vector-element-type x))))

(deftype movitz-string ()
  '(satisfies movitz-stringp))

535 536 537 538 539 540 541 542
;;;

(define-binary-class movitz-unbound-value (movitz-immediate-object)
  ())

(defmethod movitz-intern ((obj movitz-unbound-value) &optional type)
  (declare (ignore type))
  #x7fffffff)
543 544 545 546

;;; Symbols

(define-binary-class movitz-symbol (movitz-heap-object)
547
  ((function-value
548 549 550 551
    :binary-type word
    :accessor movitz-symbol-function-value
    :map-binary-write 'movitz-read-and-intern-function-value
    :map-binary-read-delayed 'movitz-word
552 553 554 555 556 557
    :initarg :function-value
    :initform 'muerte::unbound-function)
   (value
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
558
    :initform 'unbound
559 560
    :accessor movitz-symbol-value
    :initarg :value)
561 562 563
   (plist
    :binary-type word
    :accessor movitz-plist
564
    :map-binary-write 'movitz-read-and-intern
565
    :map-binary-read-delayed 'movitz-word
566 567
    :initform nil
    :initarg :plist)
568 569
   (name
    :binary-type word
570
    :map-binary-write 'movitz-read-and-intern
571
    :map-binary-read-delayed 'movitz-word
572
    :initarg :name
573 574 575
    :accessor movitz-symbol-name)
   (package
    :binary-type word
576
    :map-binary-write 'movitz-read-and-intern
577
    :map-binary-read-delayed 'movitz-word
578
    :initform nil
579 580
    :accessor movitz-symbol-package)
   (flags
581 582
    :binary-type (define-bitfield movitz-symbol-flags (lu16)
		   (((:bits)
583 584 585
		     :special-variable 3
		     :constant-variable 4
		     :setf-placeholder 5)))
586
    :accessor movitz-symbol-flags
587
    :initarg :flags
588
    :initform nil)
589 590 591 592
   (hash-key
    :binary-lisp-type lu16
    :reader movitz-symbol-hash-key
    :initarg :hash-key)
593 594 595
   (lisp-symbol
    :initform nil
    :initarg :lisp-symbol))
596
  (:slot-align function-value -7))
597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618

#+ignore
(defmethod write-binary-record :before ((obj movitz-symbol) stream)
  (declare (ignore stream))
  (setf (movitz-plist obj)
    (movitz-read
     (translate-program (translate-program (getf (movitz-environment-plists *movitz-global-environment*)
						 (slot-value obj 'lisp-symbol))
					   :cl :muerte.cl)
			:movitz :muerte))))

(defmethod movitz-object-offset ((obj movitz-symbol)) 7)

(defmethod update-movitz-object ((movitz-symbol movitz-symbol) (symbol symbol))
  (setf ;; (movitz-plist movitz-symbol) (movitz-read (symbol-plist symbol))
	(movitz-symbol-name movitz-symbol) (movitz-read (symbol-name symbol)))
  (values))

(defun make-movitz-symbol (name)
  (let ((name-string (image-read-intern-constant *image* (symbol-name name))))
    (make-instance 'movitz-symbol
      :hash-key (movitz-sxhash name-string)
619
      :name name-string
620 621 622
      :lisp-symbol name)))

(defmethod print-object ((object movitz-symbol) stream)
623 624 625
  (typecase (movitz-symbol-name object)
    (movitz-basic-vector
     (print-unreadable-object (object stream :type 'movitz-symbol)
626 627 628
       (format stream "|~A|"
	       (map 'string #'identity
		    (slot-value (slot-value object 'name) 'symbolic-data))))
629 630
     object)
    (t (call-next-method))))
631 632 633 634 635 636 637 638 639 640 641 642 643 644 645

(defun movitz-read-and-intern-function-value (obj type)
  (assert (eq type 'word))
  (cond
   ((typep obj 'movitz-funobj)
    (movitz-intern obj))
   ((symbolp obj)
    (let ((x (movitz-env-named-function obj)))
      (check-type x movitz-funobj)
      (movitz-intern x)))
   (t (error "Illegal function value: ~S." obj))))

;;; NIL


646
(define-binary-class movitz-null (movitz-symbol) ())
647 648

(defun make-movitz-nil ()
649 650 651 652 653 654 655 656 657 658
  (make-instance 'movitz-null
    :name (symbol-name nil)
    :value nil
    :plist nil
    :hash-key 0
    :flags '(:constant-variable)))

(defmethod movitz-intern ((object movitz-null) &optional (type 'word))
  (assert (eq 'word type))
  (image-nil-word *image*))
659 660

(defun movitz-null (x)
661
  (typep x 'movitz-null))
662 663

(deftype movitz-list ()
664
  `(or movitz-cons movitz-null))
665 666 667 668

;;; Compiled funobj

(define-binary-class movitz-funobj (movitz-heap-object-other)
669
  ((type
670 671 672 673 674 675 676 677 678 679 680 681 682 683
    :binary-type other-type-byte
    :initform :funobj)
   (funobj-type
    :binary-type (define-enum movitz-funobj-type (u8)
		   :standard-function 0
		   :generic-function 1
		   :method-function 2)
    :initform :standard-function
    :accessor movitz-funobj-type)
   (debug-info
    ;; Bits 0-4: The value of the start-stack-frame-setup label.
    ;; Bit    5: The code-vector's uses-stack-frame-p.
    :binary-type 'lu16
    :initform 0)
684 685 686 687 688 689 690
   (code-vector
    :binary-type code-vector-word
    :initform 'muerte::no-code-vector
    :initarg :code-vector
    :map-binary-write 'movitz-intern-code-vector
    :map-binary-read-delayed 'movitz-word-code-vector
    :accessor movitz-funobj-code-vector)
691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721
   (code-vector%1op
    :binary-type code-pointer
    :initform 'muerte::trampoline-funcall%1op
    :initarg :code-vector%1op
    :map-binary-write 'movitz-intern-code-vector
    :accessor movitz-funobj-code-vector%1op)
   (code-vector%2op
    :binary-type code-pointer
    :initform 'muerte::trampoline-funcall%2op
    :initarg :code-vector%2op
    :map-binary-write 'movitz-intern-code-vector
    :accessor movitz-funobj-code-vector%2op)
   (code-vector%3op
    :binary-type code-pointer
    :initform 'muerte::trampoline-funcall%3op
    :initarg :code-vector%3op
    :map-binary-write 'movitz-intern-code-vector
    :accessor movitz-funobj-code-vector%3op)
   (lambda-list
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word
    :reader movitz-funobj-lambda-list
    :initarg :lambda-list)
   (name
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word
    :accessor movitz-funobj-name
    :initarg :name)
   (num-jumpers				; how many of the first constants are jumpers.
722 723 724
    :binary-type lu16			; 14 bits, the lower 16 bits of a fixnum.
    :initform 0				; This, in order to see this as a fixnum while
    :accessor movitz-funobj-num-jumpers	; GC scanning.
725
    :initarg :num-jumpers
726 727 728 729 730 731 732 733
    :map-binary-write (lambda (x &optional type)
			(declare (ignore type))
			(check-type x (unsigned-byte 14))
			(* x +movitz-fixnum-factor+))
    :map-binary-read (lambda (x &optional type)
		       (declare (ignore type))
		       (assert (zerop (ldb (byte 2 0) x)))
		       (/ x +movitz-fixnum-factor+)))
734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761
   (num-constants
    :binary-type lu16
    :initform 0
    :initarg :num-constants
    :accessor movitz-funobj-num-constants)
   ;; The funobj's constants follow here..
   (constant0
    :binary-type :label)
   ;; A standard-generic-function will have three constants:
   ;; The class, the slots, and the discriminating-function.
   (const-list				;
    ;; :initform ()
    :initarg :const-list
    :accessor movitz-funobj-const-list)
   (jumpers-map
    :initarg :jumpers-map
    :accessor movitz-funobj-jumpers-map)
   (symbolic-name
    :initarg :symbolic-name
    :accessor movitz-funobj-symbolic-name)
   (symbolic-code 
    :initarg :symbolic-code
    :accessor movitz-funobj-symbolic-code)
   (symtab
    :initform nil
    :accessor movitz-funobj-symtab)
   (borrowed-bindings
    :initarg :borrowed-bindings
762
    :initform nil
763 764 765 766 767 768 769 770
    :accessor borrowed-bindings)
   (function-envs
    :accessor function-envs)
   (funobj-env
    :initarg :funobj-env
    :accessor funobj-env)   
   (extent
    :initarg :extent
771
    :initform :unused
772
    :accessor movitz-funobj-extent)
773 774
   (allocation
    :accessor movitz-allocation)
775 776 777 778 779
   (usage
    :initform nil
    :accessor movitz-funobj-usage)
   (sub-function-binding-usage		; a plist used during lexical analysis
    :initform nil
780 781 782 783
    :accessor sub-function-binding-usage)
   (entry-protocol
    :initform :default
    :initarg :entry-protocol
784 785 786 787
    :reader funobj-entry-protocol)
   (headers-on-stack-frame-p
    :initform nil
    :accessor headers-on-stack-frame-p))
788
  (:slot-align type #.+other-type-offset+))
789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808

(defmethod write-binary-record ((obj movitz-funobj) stream)
  (declare (special *record-all-funobjs*))
  (assert (movitz-funobj-code-vector obj) (obj)
    "No code-vector for funobj named ~S." (movitz-funobj-name obj))
  #+ignore
  (assert (= (movitz-funobj-num-constants obj)
	     (length (movitz-funobj-const-list obj))))
  (+ (call-next-method)			; header
     (loop for data in (movitz-funobj-const-list obj)
	 as pos upfrom 0
	 summing (if (>= pos (movitz-funobj-num-jumpers obj))
		     (write-binary 'word stream (movitz-intern data))
		   (let ((x (cdr (assoc data (movitz-funobj-symtab obj)))))
		     (assert (integerp x) ()
		       "Unable to resolve jumper ~S." data)
		     (write-binary 'u32 stream
				   (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj)))))))))

(defmethod print-object ((object movitz-funobj) stream)
809 810
  (print-unreadable-object (object stream :type t :identity t)
    (write (movitz-print (movitz-funobj-name object)) :stream stream)))
811 812 813 814 815 816 817 818 819 820 821 822

(defmethod sizeof ((obj movitz-funobj))
  (+ (sizeof (find-binary-type 'movitz-funobj))
     (* (movitz-funobj-num-constants obj)
	(sizeof 'word))))

(defun make-movitz-funobj (lambda-list &key (name ""))
  (check-type name (or symbol cons))
  (make-instance 'movitz-funobj
    :lambda-list lambda-list
    :name name))

823 824 825 826 827
(defun funobj-name (x)
  (typecase x
    (movitz-funobj
     (movitz-funobj-name x))))

828 829 830 831
;;;

(define-binary-class movitz-funobj-standard-gf (movitz-funobj)
  ;; This class is binary congruent with movitz-funobj.
832
  ((type
833 834 835 836 837 838 839 840
    :binary-type other-type-byte)
   (funobj-type
    :binary-type movitz-funobj-type
    :initform :generic-function)
   (debug-info
    ;; Bits 0-4: The value of the start-stack-frame-setup label.
    :binary-type 'lu16
    :initform 0)
841 842 843 844 845
   (code-vector
    :binary-type code-vector-word
    :initform 'muerte::standard-gf-dispatcher
    :map-binary-write 'movitz-intern-code-vector
    :map-binary-read-delayed 'movitz-word-code-vector)
846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868
   (code-vector%1op
    :initform 'muerte::standard-gf-dispatcher%1op
    :binary-type code-pointer
    :map-binary-write 'movitz-intern-code-vector)
   (code-vector%2op
    :initform 'muerte::standard-gf-dispatcher%2op
    :binary-type code-pointer
    :map-binary-write 'movitz-intern-code-vector)
   (code-vector%3op
    :initform 'muerte::standard-gf-dispatcher%3op
    :binary-type code-pointer
    :map-binary-write 'movitz-intern-code-vector)
   (lambda-list
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word)
   (name
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word)
   (num-jumpers
    :binary-type lu16
    :initform 0
869 870
    :accessor movitz-funobj-num-jumpers
    :map-binary-write (lambda (x &optional type)
871 872 873
		       (declare (ignore type))
		       (check-type x (unsigned-byte 14))
		       (* x +movitz-fixnum-factor+))
874
    :map-binary-read (lambda (x &optional type)
875 876
		       (declare (ignore type))
		       (assert (zerop (ldb (byte 2 0) x)))
877
		       (/ x +movitz-fixnum-factor+)))
878 879 880 881 882 883 884 885
   (num-constants
    :binary-type lu16
    :initform (/ (- (sizeof 'movitz-funobj-standard-gf)
		    (sizeof 'movitz-funobj))
		 4))			; XXXXXXX MUST MATCH NUMBER OF WORDS BELOW XXXXXXXXXXX
   (standard-gf-function		; a movitz-funobj which is called by dispatcher (in code-vector)
    :accessor standard-gf-function
    :initarg :function
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
886
    :initform 'muerte::unbound-function
887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918
    :binary-type word
    :map-binary-write 'movitz-read-and-intern-function-value)
   (num-required-arguments
    :initarg :num-required-arguments
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word-and-print)
   (classes-to-emf-table
    :initarg :classes-to-emf-table
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word-and-print)
   (eql-specializer-table
    :initform nil
    :initarg :eql-specializer-table
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word-and-print)
   (standard-gf-class
    :accessor standard-gf-class
    :initarg :class
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word)
   (standard-gf-slots
    :accessor standard-gf-slots
    :initarg :slots
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word)
   (plist
    :initform nil))
919
  (:slot-align type #.+other-type-offset+))
920 921 922 923 924

(defmethod movitz-funobj-const-list ((funobj movitz-funobj-standard-gf))
  nil)

(defun make-standard-gf (class slots &key lambda-list (name "unnamed")
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
925
					  (function 'muerte::unbound-function)
926 927 928 929 930 931 932 933 934 935 936 937 938
					  num-required-arguments
					  classes-to-emf-table)
  (make-instance 'movitz-funobj-standard-gf
    :lambda-list lambda-list
    :name name
    :class class
    :slots slots
    :function function
    :num-required-arguments num-required-arguments
    :classes-to-emf-table classes-to-emf-table))

;;;

939 940 941 942
(define-binary-class movitz-struct (movitz-heap-object-other)
  ((type
    :binary-type other-type-byte
    :initform :defstruct)
943 944
   (pad :binary-lisp-type 1)
   (length
945
    :binary-type lu16
946
    :initarg :length
947
    :accessor movitz-struct-length
948 949 950 951 952 953 954 955 956
    :map-binary-write (lambda (x &optional type)
			(declare (ignore type))
			(check-type x (unsigned-byte 14))
			(* x 4))
    :map-binary-read (lambda (x &optional type)
		       (declare (ignore type))
		       (assert (zerop (mod x 4)))
		       (truncate x 4)))
   (class
957
    :binary-type word
958 959
    :map-binary-write 'movitz-intern
    :map-binary-read-delayed 'movitz-word
960 961
    :reader movitz-struct-class
    :initarg :class)
962 963 964 965 966
   (slot0 :binary-lisp-type :label)	; the slot values follows here.
   (slot-values
    :initform '()
    :initarg :slot-values
    :accessor movitz-struct-slot-values))
967
  (:slot-align type #.+other-type-offset+))
968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994

(defmethod update-movitz-object ((movitz-struct movitz-struct) lisp-struct)
  (declare (ignore lisp-struct))
  (values))

(defmethod sizeof ((obj movitz-struct))
  (+ (sizeof 'movitz-struct)
     (* 4 (length (movitz-struct-slot-values obj)))))

(defmethod write-binary-record ((obj movitz-struct) stream)
  (+ (call-next-method)			; header
     (loop for slot-value in (movitz-struct-slot-values obj)
	 for slot-word = (movitz-read-and-intern slot-value 'word)
	 summing (write-binary 'word stream slot-word))))

(defmethod read-binary-record ((type-name (eql 'movitz-struct)) stream &key)
  (let ((object (call-next-method)))
    (setf (movitz-struct-slot-values object)
      (loop for i from 1 to (movitz-struct-length object)
	  collect
	    (let ((word (read-binary 'word stream)))
	      (with-image-stream-position-remembered ()
		(movitz-word word)))))
    object))

(defmethod print-object ((object movitz-struct) stream)
  (print-unreadable-object (object stream :type t)
995
    (format stream "~S" (slot-value object 'class))))
996 997 998 999 1000

;;;


(defconstant +undefined-hash-key+
1001
    'muerte::--no-hash-key--)
1002 1003 1004 1005

(defun movitz-sxhash (object)
  "Must match the SXHASH function in :cl/hash-tables."
  (typecase object
1006 1007
    (movitz-null
     0)
1008 1009 1010 1011 1012 1013 1014 1015 1016
    (movitz-symbol
     (movitz-symbol-hash-key object))
    (movitz-string
     (let ((object (movitz-print object))
	   (result 0))
       (dotimes (i (min 8 (length object)))
	 (incf result result)
	 (incf result
	       (if (evenp i)
1017 1018
		   (char-code (char-upcase (aref object i)))
		 (* 7 (char-code (char-upcase (aref object i)))))))
1019 1020 1021 1022 1023 1024 1025 1026
       (ldb (byte 16 0)
	    (+ (* #x10ad (length object))
	       result))))
    (movitz-fixnum
     (movitz-fixnum-value object))
    (t (warn "Don't know how to take SXHASH of ~S." object)
       0)))

1027 1028
(defvar *hash-table-size-factor* 5/4)

1029 1030
(defun make-movitz-hash-table (lisp-hash)
  (let* ((undef (movitz-read +undefined-hash-key+))
1031
	 (hash-count (hash-table-count lisp-hash))
1032 1033
	 (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count)
					    *hash-table-size-factor*))))
1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045
	 (bucket-data (make-array hash-size :initial-element undef)))
    (multiple-value-bind (hash-test hash-sxhash)
	(ecase (hash-table-test lisp-hash)
	  (eq (values 'muerte.cl:eq 'muerte::sxhash-eq))
	  (eql (values 'muerte.cl:eql 'muerte.cl::sxhash))
	  (equal (values 'muerte.cl:equal 'muerte.cl::sxhash)))
      (loop for key being the hash-keys of lisp-hash using (hash-value value)
	  for movitz-key = (movitz-read key)
	  for movitz-value = (movitz-read value)
	  do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size)
		 then (rem (+ 2 pos) hash-size)
		 until (eq undef (svref bucket-data pos))
1046 1047
;;;		 do (warn "Hash collision at ~D of ~D: ~S ~S!"
;;;			  pos hash-size movitz-key (elt bucket-data pos))
1048 1049 1050 1051 1052 1053 1054
;;;	       finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value)
;;;	       finally (when (equal "NIL" key)
;;;			 (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos))
		 finally (setf (svref bucket-data pos) movitz-key
			       (svref bucket-data (1+ pos)) movitz-value)))
      (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data))
	     (lh (make-instance 'movitz-struct
1055
		   :class (muerte::movitz-find-class 'muerte::hash-table)
1056
		   :length 4
1057 1058
		   :slot-values (list hash-test ; test-function
				      bucket
1059 1060
				      hash-sxhash
				      hash-count))))
1061 1062 1063 1064
	lh))))

(defmethod update-movitz-object ((movitz-hash movitz-struct) (lisp-hash hash-table))
  "Keep <movitz-hash> in sync with <lisp-hash>."
1065
  (assert (= 4 (length (movitz-struct-slot-values movitz-hash))))
1066 1067
  (let* ((undef (movitz-read +undefined-hash-key+))
	 (old-bucket (second (movitz-struct-slot-values movitz-hash)))
1068
	 (hash-count (hash-table-count lisp-hash))
1069 1070
	 (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count)
					    *hash-table-size-factor*))))
1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087
	 (bucket-data (or (and old-bucket
			       (= (length (movitz-vector-symbolic-data old-bucket))
				  hash-size)
			       (fill (movitz-vector-symbolic-data old-bucket) undef))
			  (make-array hash-size :initial-element undef))))
    (multiple-value-bind (hash-test hash-sxhash)
	(ecase (hash-table-test lisp-hash)
	  (eq (values 'muerte.cl:eq 'muerte::sxhash-eq))
	  (eql (values 'muerte.cl:eql 'muerte.cl::sxhash))
	  (equal (values 'muerte.cl:equal 'muerte.cl::sxhash)))
      (loop for key being the hash-keys of lisp-hash using (hash-value value)
	  for movitz-key = (movitz-read key)
	  for movitz-value = (movitz-read value)
	  do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size)
		 then (rem (+ 2 pos) hash-size)
		 until (eq undef (svref bucket-data pos))
;;;	       do (warn "Hash collision at ~D of ~D: ~S ~S!"
1088
;;;			pos hash-size movitz-key (elt bucket-data pos))
1089 1090 1091
;;;	       finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value)
;;;	       finally (when (equal "NIL" key)
;;;			 (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos))
1092 1093 1094
		 finally
		   (setf (svref bucket-data pos) movitz-key
			 (svref bucket-data (1+ pos)) movitz-value)))
1095 1096
      (setf (first (movitz-struct-slot-values movitz-hash)) hash-test
	    (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data)
1097 1098
	    (third (movitz-struct-slot-values movitz-hash)) hash-sxhash
	    (fourth (movitz-struct-slot-values movitz-hash)) hash-count)
1099 1100 1101 1102
      movitz-hash)))
					     
;;;

1103 1104 1105
;;;(unless (typep *movitz-nil* 'movitz-nil)
;;;  (warn "Creating new *MOVITZ-NIL* object!")
;;;  (setf *movitz-nil* (make-movitz-nil)))
1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144


(define-binary-class gate-descriptor ()
  ((offset-low
    :binary-type u16
    :initarg offset-low)
   (selector
    :binary-type u16
    :initarg selector)
   (count
    :binary-type u8
    :initarg count)
   (access
    :initarg access
    :binary-type (define-bitfield gate-descriptor-access (u8)
		   (((:numeric privilege-level 2 5))
		    ((:enum :byte (5 0)) :task         #x5
					 :interrupt    #xe
					 :interrupt-16 #x6
					 :trap         #xf
					 :trap-16      #x7)
		    ((:bits) segment-present 7))))
   (offset-high
    :binary-type u16
    :initarg offset-high)))

(defun make-gate-descriptor (type offset &key (segment-selector 0) (privilege 0) (count 0))
  (check-type offset (unsigned-byte 32))
  (check-type count (integer 0 31))
  (check-type privilege (integer 0 3))
  (make-instance 'gate-descriptor
    'offset-low (ldb (byte 16 0) offset)
    'offset-high (ldb (byte 16 16) offset)
    'selector segment-selector
    'count (ldb (byte 5 0) count)
    'access (list `(privilege-level . ,privilege)
		  type
		  'segment-present)))

1145 1146
(defun map-interrupt-trampolines-to-idt (trampolines type)
  (check-type trampolines vector)
1147
  (assert (eq type 'word))
1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163
  (let* ((byte-list
	  (with-binary-output-to-list (bytes)
	    (loop for trampoline across trampolines
		as exception-vector upfrom 0
		do (let* ((trampoline-address (movitz-intern (find-primitive-function trampoline)))
			  (symtab (movitz-env-get trampoline :symtab))
			  (trampoline-offset (cdr (assoc exception-vector symtab))))
		     (assert symtab ()
		       "No symtab for exception trampoline ~S." trampoline)
		     (write-binary-record
		      (make-gate-descriptor ':interrupt
					    (+ (slot-offset 'movitz-basic-vector 'data)
					       trampoline-address
					       trampoline-offset)
					    :segment-selector (* 3 8))
		      bytes))))))
1164 1165
    (let ((l32 (merge-bytes byte-list 8 32)))
      (movitz-intern (make-movitz-vector (length l32)
1166 1167
					 :element-type '(unsigned-byte 32)
					 :initial-contents l32)))))
1168 1169 1170 1171 1172


;;; std-instance

(define-binary-class movitz-std-instance (movitz-heap-object-other)
1173 1174 1175 1176 1177
  ((type
    :binary-type other-type-byte
    :initform :std-instance)
   (pad :binary-lisp-type 3)
   (dummy
1178
    :binary-type word
1179 1180
    :initform nil
    :map-binary-write 'movitz-read-and-intern
1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193
    :map-binary-read-delayed 'movitz-word)
   (class
    :binary-type word
    :map-binary-write 'movitz-intern
    :map-binary-read-delayed 'movitz-word
    :initarg :class
    :accessor movitz-std-instance-class)
   (slots
    :binary-type word
    :map-binary-write 'movitz-read-and-intern
    :map-binary-read-delayed 'movitz-word
    :initarg :slots
    :accessor movitz-std-instance-slots))
1194
  (:slot-align type #.+other-type-offset+))
1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210

;; (defmethod movitz-object-offset ((obj movitz-std-instance)) (- #x1e))

(defun make-movitz-std-instance (class slots)
  (make-instance 'movitz-std-instance
    :class (movitz-read class)
    :slots slots))

(defmethod print-object ((object movitz-std-instance) stream)
  (print-unreadable-object (object stream :identity t)
    (format stream "movitz-obj")
    (when (not (boundp '*movitz-obj-no-recurse*))
      (let ((*print-level* nil)
	    (*movitz-obj-no-recurse* t))
	(declare (special *movitz-obj-no-recurse*))
	(write-char #\space stream)
1211
	(write (aref (movitz-print (slot-value object 'slots)) 0)
1212 1213 1214
	       :stream stream))))
  object)

1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227
;;;;

(define-binary-class movitz-bignum (movitz-heap-object-other)
  ((type
    :binary-type other-type-byte
    :initform :bignum)
   (sign
    :binary-type u8
    :initarg :sign
    :accessor movitz-bignum-sign)
   (length
    :binary-type lu16
    :initarg :length
1228 1229 1230 1231 1232 1233 1234 1235 1236
    :accessor movitz-bignum-length
    :map-binary-write (lambda (x &optional type)
			(declare (ignore type))
			(check-type x (unsigned-byte 14))
			(* x 4))
    :map-binary-read (lambda (x &optional type)
		       (declare (ignore type))
		       (assert (zerop (mod x 4)))
		       (truncate x 4)))
1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261
   (bigit0 :binary-type :label)
   (value
    :initarg :value
    :accessor movitz-bignum-value))
  (:slot-align type #.+other-type-offset+))

(defmethod write-binary-record ((obj movitz-bignum) stream)
  (let* ((num (movitz-bignum-value obj))
	 (length (ceiling (integer-length (abs num)) 32)))
    (check-type length (unsigned-byte 16))
    (setf (movitz-bignum-length obj) length
	  (movitz-bignum-sign obj) (if (minusp num) #xff #x00))
    (+ (call-next-method)		; header
       (loop for b from 0 below length
	   summing (write-binary 'lu32 stream (ldb (byte 32 (* b 32)) (abs num)))))))

(defun make-movitz-integer (value)
  (if (<= +movitz-most-negative-fixnum+ value +movitz-most-positive-fixnum+)
      (make-movitz-fixnum value)
    (make-instance 'movitz-bignum
      :value value)))

(defmethod sizeof ((obj movitz-bignum))
  (+ (sizeof 'movitz-bignum)
     (* 4 (ceiling (integer-length (abs (movitz-bignum-value obj))) 32))))
1262 1263 1264 1265

(defmethod update-movitz-object ((object movitz-bignum) lisp-object)
  (assert (= (movitz-bignum-value object) lisp-object))
  object)
1266

1267

1268 1269 1270 1271 1272 1273 1274 1275 1276
(defmethod read-binary-record ((type-name (eql 'movitz-bignum)) stream &key)
  (let* ((header (call-next-method))
	 (x (loop for i from 0 below (movitz-bignum-length header)
		summing (ash (read-binary 'u32 stream) (* i 32)))))
    (setf (movitz-bignum-value header)
      (ecase (movitz-bignum-sign header)
	(#x00 x)
	(#xff (- x))))
    header))
1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310

(define-binary-class movitz-ratio (movitz-heap-object-other)
  ((type
    :binary-type other-type-byte
    :initform :ratio)
   (dummy0
    :binary-type u8
    :initform 0)
   (dummy1
    :binary-type lu16
    :initform 0)
   (dummy2
    :binary-type word
    :initform 0)
   (numerator
    :binary-type word
    :map-binary-read-delayed 'movitz-word
    :map-binary-write 'movitz-read-and-intern)
   (denominator
    :binary-type word
    :map-binary-read-delayed 'movitz-word
    :map-binary-write 'movitz-read-and-intern)
   (value
    :reader movitz-ratio-value
    :initarg :value))
  (:slot-align type #.+other-type-offset+))

(defmethod write-binary-record ((obj movitz-ratio) stream)
  (declare (ignore stream))
  (let ((value (movitz-ratio-value obj)))
    (check-type value ratio)
    (setf (slot-value obj 'numerator) (numerator value)
	  (slot-value obj 'denominator) (denominator value))
    (call-next-method)))
1311 1312 1313 1314 1315 1316


(defmethod update-movitz-object ((object movitz-ratio) lisp-object)
  (assert (= (movitz-ratio-value object) lisp-object))
  object)

1317 1318 1319 1320
(defmethod update-movitz-object ((object movitz-ratio) (lisp-object float))
  (assert (= (movitz-ratio-value object) (rationalize lisp-object)))
  object)

1321 1322 1323 1324 1325
(defmethod print-object ((x movitz-ratio) stream)
  (print-unreadable-object (x stream :type t)
    (format stream "~D" (slot-value x 'value)))
  x)