storage-types.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      storage-types.lisp
   7 ;;;; Description:   Physical storage structures for Movitz objects.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Sun Oct 22 00:22:43 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: storage-types.lisp,v 1.59 2007/02/06 20:03:53 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package movitz)
  17
  18 (define-unsigned lu64 8 :little-endian)
  19
  20 (define-bitfield segment-descriptor (lu64)
  21   (((:numeric limit0 16 0))
  22    ((:numeric limit1 4 48))
  23    ((:numeric base0 24 16))
  24    ((:numeric base1 8 56))
  25    ((:numeric type 4 40))
  26    ((:numeric dpl 2 45))
  27    ((:bits)
  28     s 44
  29     p 47
  30     avl 52
  31     reserved 53
  32     d/b 54
  33     g 55)))
  34
  35 (defun make-segment-descriptor (&key (limit 0) (base 0) (type 0) (dpl 0) (flags nil))
  36   (check-type limit (unsigned-byte 20))
  37   (check-type base (unsigned-byte 32))
  38   `((limit0 . ,(ldb (byte 16 0) limit))
  39     (limit1 . ,(ldb (byte 4 16) limit))
  40     (base0  . ,(ldb (byte 24 0) base))
  41     (base1  . ,(ldb (byte 8 24) base))
  42     (type   . ,type)
  43     (dpl    . ,dpl)
  44     ,@flags))
  45
  46 (defmacro with-image-stream-position-remembered (opts &body body)
  47   (declare (ignore opts))
  48   (let ((v (gensym)))
  49     `(let ((,v (file-position (image-stream *image*))))
  50        (unwind-protect (progn ,@body)
  51          (file-position (image-stream *image*) ,v)))))
  52
  53 (define-enum other-type-byte (u8)
  54   :fixnum 0
  55   :even-fixnum 0
  56   :odd-fixnum 4
  57   :cons 1
  58   :character 2
  59   :tag0 0
  60   :tag1 1
  61   :tag2 2
  62   :tag3 3                               ; unused
  63   :tag4 4
  64   :tag5 5
  65   :tag6 6
  66   :tag7 7
  67   ;; :immediate 4
  68   :null 5
  69   :other 6
  70   :symbol 7
  71
  72   :basic-vector #x22
  73   :defstruct #x2a
  74   :funobj #x3a
  75   :bignum #x4a
  76   :ratio #x52
  77   :complex #x5a
  78   :std-instance #x40
  79   :run-time-context #x50
  80   :illegal #x13
  81   :infant-object #x23
  82   :basic-restart #x32
  83   )
  84
  85 (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum))
  86 (defparameter +scan-skip-word+ #x00000003)
  87
  88 (defun tag (type &optional (wide-tag 0))
  89   (logior (bt:enum-value 'other-type-byte type)
  90           (ash wide-tag 8)))
  91
  92 (defun tag-name (number)
  93   (find number '(:even-fixnum :odd-fixnum :cons :character :null :other :symbol)
  94         :key 'tag))
  95
  96 (defun extract-tag (word)
  97   (tag-name (ldb (byte 3 0) word)))
  98
  99 (defun extract-pointer (word)
 100   (logand word #xfffffff8))
 101
 102 (defun slot-map (type &optional (offset 0))
 103   (let ((slots (binary-record-slot-names type)))
 104     (loop for slot in slots
 105         as o = (- (bt:slot-offset type slot) offset)
 106         collect (list (intern (symbol-name slot) :muerte)
 107                       (intern (symbol-name (binary-slot-type type slot)) :muerte)
 108                       (truncate o 4)
 109                       (rem o 4)))))
 110
 111 (define-unsigned word 4 :little-endian)
 112 (define-unsigned code-vector-word 4 :little-endian) ; A word that points to a code-vector, +2
 113 (define-unsigned code-pointer 4 :little-endian) ; A pointer anywhere, pointing to code.
 114
 115 (defclass movitz-object ()
 116   ((browsed-slots
 117     :initarg :browser-properties
 118     :initform nil
 119     :accessor movitz-object-browser-properties)))
 120
 121 (defclass movitz-immediate-object (movitz-object) ())
 122 (defclass movitz-heap-object (movitz-object)
 123   ((word
 124     :accessor movitz-heap-object-word)))
 125 (defclass movitz-heap-object-other (movitz-heap-object) ())
 126
 127 (defmethod movitz-object-offset ((obj movitz-heap-object-other)) 6)
 128 (defmethod movitz-storage-alignment ((obj movitz-heap-object)) 8)
 129 (defmethod movitz-storage-alignment-offset ((obj movitz-heap-object)) 0)
 130
 131 ;;;
 132
 133 (defgeneric movitz-references (obj)
 134   (:documentation "Return the objects referenced by OBJ."))
 135
 136 (defmethod movitz-references (obj)
 137   (mapcar #'(lambda (slot)
 138               (slot-value obj slot))
 139           (binary-record-slot-names (find-binary-type (type-of obj)))))
 140
 141
 142 (defmethod movitz-intern ((obj movitz-heap-object) &optional type)
 143   (declare (ignore type))
 144   (image-intern-object *image* obj))
 145
 146 (defmethod movitz-intern ((obj movitz-immediate-object) &optional type)
 147   (declare (ignore type))
 148   (movitz-immediate-value obj))
 149
 150 (defun movitz-read-and-intern (expr type)
 151   (ecase type
 152     (word
 153      (cond
 154       ((typep expr 'movitz-object)
 155        (movitz-intern expr))
 156       (t (movitz-intern (movitz-read expr)))))
 157     (code-vector-word
 158      (movitz-intern-code-vector expr))))
 159
 160 (defmethod update-movitz-object ((obj movitz-heap-object) lisp-obj)
 161   (declare (ignore lisp-obj))
 162   (break "Don't know how to update ~W." obj))
 163
 164 (defmethod update-movitz-object ((obj movitz-immediate-object) lisp-obj)
 165   (declare (ignore lisp-obj))
 166   (values))
 167
 168 ;;; Fixnums
 169
 170 (eval-when (:compile-toplevel :execute :load-toplevel)
 171   (defparameter +movitz-fixnum-bits+ 30)
 172   (defparameter +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
 173   (defparameter +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
 174   (defparameter +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
 175   (defparameter +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
 176   (defparameter +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))
 177
 178   (defparameter +object-pointer-shift+ 0)
 179   (defparameter +other-type-offset+ (- -6 +object-pointer-shift+)))
 180
 181 (defun fixnum-integer (word)
 182   "For a Movitz word, that must be a fixnum, return the corresponding
 183 integer (native lisp) value."
 184   (assert (member (extract-tag word) +fixnum-tags+) (word)
 185     "The word ~W is not a fixnum." word)
 186   (let ((x (ldb (byte (1- +movitz-fixnum-bits+)
 187                       (- 32 +movitz-fixnum-bits+))
 188                 word)))
 189     (if (logbitp 31 word)
 190         (- (1+ (logxor x +movitz-most-positive-fixnum+)))
 191       x)))
 192
 193 (define-binary-class movitz-fixnum (movitz-immediate-object)
 194   ((value :binary-type word
 195           :initarg :value
 196           :reader movitz-fixnum-value)))
 197
 198 (defmethod print-object ((object movitz-fixnum) stream)
 199   (print-unreadable-object (object stream :type t)
 200     (write (movitz-fixnum-value object) :stream stream))
 201   object)
 202
 203 (defun make-movitz-fixnum (value)
 204   (check-type value (signed-byte #.+movitz-fixnum-bits+))
 205   (make-instance 'movitz-fixnum :value value))
 206
 207 (defmethod movitz-immediate-value ((obj movitz-fixnum))
 208   (dpb (movitz-fixnum-value obj)
 209        (byte +movitz-fixnum-bits+ (- 32 +movitz-fixnum-bits+))
 210        0))
 211
 212 (defclass movitz-unboxed-integer (movitz-immediate-object) ())
 213 (defclass movitz-unboxed-integer-u8 (movitz-unboxed-integer) ())
 214 (defclass movitz-unboxed-integer-u32 (movitz-unboxed-integer) ())
 215
 216 ;;; Characters
 217
 218 (define-binary-class movitz-character (movitz-immediate-object)
 219   ((char :binary-type word
 220          :initarg :char
 221          :type character
 222          :reader movitz-char)))
 223
 224 (defun make-movitz-character (char)
 225   (check-type char character)
 226   (make-instance 'movitz-character :char char))
 227
 228 (defmethod movitz-immediate-value ((obj movitz-character))
 229   (dpb (char-code (movitz-char obj))
 230        (byte 8 8)
 231        (tag :character)))
 232
 233 (defmethod print-object ((x movitz-character) stream)
 234   (print-unreadable-object (x stream)
 235     (format stream "MOVITZ-CHARACTER: ~S" (movitz-char x))))
 236
 237 (defun movitz-eql (x y)
 238   (if (and (typep x 'movitz-immediate-object)
 239            (typep y 'movitz-immediate-object))
 240       (= (movitz-immediate-value x)
 241          (movitz-immediate-value y))
 242     (eq x y)))
 243
 244 ;;; Code element
 245
 246 (define-binary-class movitz-code (movitz-immediate-object)
 247   ((byte :binary-type (define-unsigned code 1)
 248          :reader movitz-code-byte
 249          :initarg byte)))
 250
 251 (defun make-movitz-code (byte)
 252   (make-instance 'movitz-code 'byte byte))
 253
 254 ;;; Conses
 255
 256 (define-binary-class movitz-cons (movitz-heap-object)
 257   ((car :binary-type word
 258         :map-binary-write 'movitz-intern
 259         :map-binary-read-delayed 'movitz-word
 260         :initarg :car
 261         :accessor movitz-car)
 262    (cdr :binary-type word
 263         :map-binary-write 'movitz-intern
 264         :map-binary-read-delayed 'movitz-word
 265         :initarg :cdr
 266         :accessor movitz-cdr))
 267   (:slot-align car #.(- -1 +object-pointer-shift+)))
 268
 269 (defmethod movitz-object-offset ((obj movitz-cons)) 1)
 270
 271 (defmethod update-movitz-object ((movitz-cons movitz-cons) (lisp-cons cons))
 272   (setf (movitz-car movitz-cons) (movitz-read (car lisp-cons))
 273         (movitz-cdr movitz-cons) (movitz-read (cdr lisp-cons))))
 274
 275 (defun make-movitz-cons (car cdr)
 276   (check-type car movitz-object)
 277   (check-type cdr movitz-object)
 278   (make-instance 'movitz-cons
 279     :car car
 280     :cdr cdr))
 281
 282 (defun print-cons (ic stream)
 283   (typecase (movitz-cdr ic)
 284     (movitz-null (format stream "~A" (movitz-car ic)))
 285     (movitz-cons (format stream "~A " (movitz-car ic)))
 286     (t (format stream "~A . ~A" (movitz-car ic) (movitz-cdr ic)))))
 287
 288 (defun movitz-list-length (x)
 289   (etypecase x
 290     (list (list-length x))
 291     (movitz-null 0)
 292     (movitz-cons
 293      (flet ((movitz-endp (x) (eq x *movitz-nil*)))
 294        (do ((n 0 (+ n 2))               ;Counter.
 295             (fast x (movitz-cdr (movitz-cdr fast))) ;Fast pointer: leaps by 2.
 296             (slow x (movitz-cdr slow))) ;Slow pointer: leaps by 1.
 297            (nil)
 298          ;; If fast pointer hits the end, return the count.
 299          (when (movitz-endp fast) (return n))
 300          (when (movitz-endp (movitz-cdr fast)) (return (+ n 1)))
 301          ;; If fast pointer eventually equals slow pointer,
 302          ;;  then we must be stuck in a circular list.
 303          ;; (A deeper property is the converse: if we are
 304          ;;  stuck in a circular list, then eventually the
 305          ;;  fast pointer will equal the slow pointer.
 306          ;;  That fact justifies this implementation.)
 307          (when (and (eq fast slow) (> n 0))
 308            (warn "Circular list: ~S" x)
 309            (return nil)))))))
 310
 311 (defmethod print-object ((obj movitz-cons) stream)
 312   (format stream "#&(")
 313   (loop for ic = obj then (movitz-cdr ic) as i from 0 to (or *print-length* 100)
 314       while (typep ic 'movitz-cons)
 315       do (print-cons ic stream)
 316       finally (if (>= i 16)
 317                   (format stream "...)")
 318                 (format stream ")")))
 319   obj)
 320
 321 (defun movitz-nthcdr (n movitz-list)
 322   (if (zerop n)
 323       movitz-list
 324     (movitz-nthcdr (1- n) (movitz-cdr movitz-list))))
 325
 326 (defun (setf movitz-last-cdr) (value movitz-list)
 327   (if (not (typep (movitz-cdr movitz-list) 'movitz-cons))
 328       (setf (movitz-cdr movitz-list) value)
 329     (setf (movitz-last-cdr (movitz-cdr movitz-list)) value)))
 330
 331 ;;; movitz-vectors
 332
 333 (define-binary-class movitz-basic-vector (movitz-heap-object-other)
 334   ((type
 335     :binary-type other-type-byte
 336     :reader movitz-vector-type
 337     :initform :basic-vector)
 338    (element-type
 339     :binary-type (define-enum movitz-vector-element-type (u8)
 340                    :any-t 0
 341                    :character 1
 342                    :u8 2
 343                    :u16 3
 344                    :u32 4
 345                    :bit 5
 346                    :code 6
 347                    :indirects 7)
 348     :initarg :element-type
 349     :reader movitz-vector-element-type)
 350    (fill-pointer
 351     :binary-type lu16
 352     :initarg :fill-pointer
 353     :accessor movitz-vector-fill-pointer
 354     :map-binary-write (lambda (x &optional type)
 355                         (declare (ignore type))
 356                         (check-type x (unsigned-byte 14))
 357                         (* x 4))
 358     :map-binary-read (lambda (x &optional type)
 359                        (declare (ignore type))
 360                        (assert (zerop (mod x 4)))
 361                        (truncate x 4)))
 362    (num-elements
 363     :binary-type word
 364     :initarg :num-elements
 365     :reader movitz-vector-num-elements
 366     :map-binary-write 'movitz-read-and-intern
 367     :map-binary-read-delayed 'movitz-word-and-print)
 368    (data
 369     :binary-lisp-type :label)           ; data follows physically here
 370    (symbolic-data
 371     :initarg :symbolic-data
 372     :initform nil
 373     :accessor movitz-vector-symbolic-data))
 374   (:slot-align type #.+other-type-offset+))
 375
 376 (defmethod print-object ((object movitz-basic-vector) stream)
 377   (cond
 378    ((eq :character (movitz-vector-element-type object))
 379     (print-unreadable-object (object stream :type t :identity nil)
 380       (write (map 'string #'identity (movitz-vector-symbolic-data object))
 381              :stream stream))
 382     object)
 383    (t (call-next-method))))
 384
 385 (defun basic-vector-type-tag (element-type)
 386   (dpb (enum-value 'movitz-vector-element-type element-type)
 387        (byte 8 8)
 388        (enum-value 'other-type-byte :basic-vector)))
 389
 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 (defun movitz-svref (vector index)
 395   (elt (movitz-vector-symbolic-data vector) index))
 396
 397 (defun movitz-vector-element-type-size (element-type)
 398   (ecase element-type
 399     ((:any-t :u32) 32)
 400     ((:character :u8 :code) 8)
 401     (:u16 16)
 402     (:bit 1)))
 403
 404 (defmethod update-movitz-object ((movitz-vector movitz-basic-vector) (vector vector))
 405   (when (eq :any-t (movitz-vector-element-type movitz-vector))
 406     (loop for i from 0 below (length vector)
 407         do (setf (aref (movitz-vector-symbolic-data movitz-vector) i)
 408              (movitz-read (aref vector i)))))
 409   (values))
 410
 411 (defmethod write-binary-record ((obj movitz-basic-vector) stream)
 412   (flet ((write-element (type stream data)
 413            (ecase type
 414              ((:u8 :code)(write-binary 'u8 stream data))
 415              (:u16       (write-binary 'u16 stream data))
 416              (:u32       (write-binary 'u32 stream data))
 417              (:character (write-binary 'char8 stream data))
 418              (:any-t     (write-binary 'word stream (movitz-read-and-intern data 'word))))))
 419     (+ (call-next-method)               ; header
 420        (etypecase (movitz-vector-symbolic-data obj)
 421          (list
 422           (loop for data in (movitz-vector-symbolic-data obj)
 423               with type = (movitz-vector-element-type obj)
 424               summing (write-element type stream data)))
 425          (vector
 426           (loop for data across (movitz-vector-symbolic-data obj)
 427               with type = (movitz-vector-element-type obj)
 428               summing (write-element type stream data)))))))
 429
 430 (defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys)
 431   (let ((object (call-next-method)))
 432     (setf (movitz-vector-symbolic-data object)
 433       (loop for i from 1 to (movitz-vector-num-elements object)
 434           collecting
 435             (ecase (movitz-vector-element-type object)
 436               ((:u8 :code)(read-binary 'u8 stream))
 437               (:u16       (read-binary 'u16 stream))
 438               (:u32       (read-binary 'u32 stream))
 439               (:character (read-binary 'char8 stream))
 440               (:any-t     (let ((word (read-binary 'word stream)))
 441                             (with-image-stream-position-remembered ()
 442                               (movitz-word word)))))))
 443     object))
 444
 445 (defmethod sizeof ((object movitz-basic-vector))
 446   (+ (call-next-method)
 447      (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type))
 448                  (slot-value object 'num-elements))
 449               8)))
 450
 451 (defun movitz-vector-upgrade-type (type)
 452   (cond
 453    ((eq type 'code)
 454     (values :code 0))
 455    ((subtypep type '(unsigned-byte 8))
 456     (values :u8 0))
 457    ((subtypep type '(unsigned-byte 16))
 458     (values :u16 0))
 459    ((subtypep type '(unsigned-byte 32))
 460     (values :u32 0))
 461    ((subtypep type 'character)
 462     (values :character #\null))
 463    (t (values :any-t nil)))
 464   #+ignore (case type
 465              (movitz-unboxed-integer-u8
 466               (values :u8 0))
 467              (movitz-unboxed-integer-u32
 468               (values :u32 0))
 469              (movitz-character
 470               (values :character #\null))
 471              (movitz-code
 472               (values :code 0))
 473              (t (values :any-t nil))))
 474
 475 (defun make-movitz-vector (size &key (element-type t)
 476                                      (initial-contents nil)
 477                                      (initial-element *movitz-nil* initial-element-p)
 478                                      (alignment 8)
 479                                      (alignment-offset 0)
 480                                      (flags nil)
 481                                      fill-pointer)
 482   (assert (or (null initial-contents)
 483               (= size (length initial-contents))) (size initial-contents)
 484     "The initial-contents must be the same length as SIZE.")
 485 ;;;  (assert (subtypep element-type 'movitz-object) ()
 486 ;;;    "ELEMENT-TYPE must be a subtype of MOVITZ-OBJECT.")
 487 ;;;  (assert (or initial-contents
 488 ;;;           (not initial-element-p)
 489 ;;;           (typep initial-element element-type)) ()
 490 ;;;    "INITIAL-ELEMENT's type ~A is not of ELEMENT-TYPE ~A."
 491 ;;;    (type-of initial-element) element-type)
 492   (assert (and (>= (log alignment 2) 3)
 493                (zerop (rem (log alignment 2) 1)))
 494       (alignment)
 495     "Illegal alignment: ~A." alignment)
 496   (multiple-value-bind (et default-element)
 497       (movitz-vector-upgrade-type element-type)
 498     (when initial-element-p
 499       (assert (not initial-contents) ()
 500         "Can't provide both initial-element and initial-contents."))
 501     (unless initial-contents
 502       (setf initial-contents
 503         (make-array size :initial-element (or (and initial-element-p initial-element)
 504                                               default-element))))
 505     (assert (member et '(:any-t :character :u8 :u32 :code)))
 506     (when flags (break "flags: ~S" flags))
 507     (when (and alignment-offset (plusp alignment-offset))
 508       (break "alignment: ~S" alignment-offset))
 509     (make-instance 'movitz-basic-vector
 510       :element-type et
 511       :num-elements size
 512       :symbolic-data (case et
 513                        (:any-t
 514                         (map 'vector #'movitz-read initial-contents))
 515                        (t initial-contents))
 516       :fill-pointer (cond
 517                      ((not (typep size '(unsigned-byte 14)))
 518                       0)
 519                      ((integerp fill-pointer)
 520                       fill-pointer)
 521                      (t size)))))
 522
 523 (defun make-movitz-string (string)
 524   (make-movitz-vector (length string)
 525                    :element-type 'character
 526                    :initial-contents (map 'list #'identity string)))
 527
 528 (defun movitz-stringp (x)
 529   (and (typep x '(or movitz-basic-vector))
 530        (eq :character (movitz-vector-element-type x))))
 531
 532 (deftype movitz-string ()
 533   '(satisfies movitz-stringp))
 534
 535 ;;;
 536
 537 (define-binary-class movitz-unbound-value (movitz-immediate-object)
 538   ())
 539
 540 (defmethod movitz-intern ((obj movitz-unbound-value) &optional type)
 541   (declare (ignore type))
 542   #x7fffffff)
 543
 544 ;;; Symbols
 545
 546 (define-binary-class movitz-symbol (movitz-heap-object)
 547   ((function-value
 548     :binary-type word
 549     :accessor movitz-symbol-function-value
 550     :map-binary-write 'movitz-read-and-intern-function-value
 551     :map-binary-read-delayed 'movitz-word
 552     :initarg :function-value
 553     :initform 'muerte::unbound-function)
 554    (value
 555     :binary-type word
 556     :map-binary-write 'movitz-read-and-intern
 557     :map-binary-read-delayed 'movitz-word
 558     :initform 'unbound
 559     :accessor movitz-symbol-value
 560     :initarg :value)
 561    (plist
 562     :binary-type word
 563     :accessor movitz-plist
 564     :map-binary-write 'movitz-read-and-intern
 565     :map-binary-read-delayed 'movitz-word
 566     :initform nil
 567     :initarg :plist)
 568    (name
 569     :binary-type word
 570     :map-binary-write 'movitz-read-and-intern
 571     :map-binary-read-delayed 'movitz-word
 572     :initarg :name
 573     :accessor movitz-symbol-name)
 574    (package
 575     :binary-type word
 576     :map-binary-write 'movitz-read-and-intern
 577     :map-binary-read-delayed 'movitz-word
 578     :initform nil
 579     :accessor movitz-symbol-package)
 580    (flags
 581     :binary-type (define-bitfield movitz-symbol-flags (lu16)
 582                    (((:bits)
 583                      :special-variable 3
 584                      :constant-variable 4
 585                      :setf-placeholder 5)))
 586     :accessor movitz-symbol-flags
 587     :initarg :flags
 588     :initform nil)
 589    (hash-key
 590     :binary-lisp-type lu16
 591     :reader movitz-symbol-hash-key
 592     :initarg :hash-key)
 593    (lisp-symbol
 594     :initform nil
 595     :initarg :lisp-symbol))
 596   (:slot-align function-value -7))
 597
 598 #+ignore
 599 (defmethod write-binary-record :before ((obj movitz-symbol) stream)
 600   (declare (ignore stream))
 601   (setf (movitz-plist obj)
 602     (movitz-read
 603      (translate-program (translate-program (getf (movitz-environment-plists *movitz-global-environment*)
 604                                                  (slot-value obj 'lisp-symbol))
 605                                            :cl :muerte.cl)
 606                         :movitz :muerte))))
 607
 608 (defmethod movitz-object-offset ((obj movitz-symbol)) 7)
 609
 610 (defmethod update-movitz-object ((movitz-symbol movitz-symbol) (symbol symbol))
 611   (setf ;; (movitz-plist movitz-symbol) (movitz-read (symbol-plist symbol))
 612         (movitz-symbol-name movitz-symbol) (movitz-read (symbol-name symbol)))
 613   (values))
 614
 615 (defun make-movitz-symbol (name)
 616   (let ((name-string (image-read-intern-constant *image* (symbol-name name))))
 617     (make-instance 'movitz-symbol
 618       :hash-key (movitz-sxhash name-string)
 619       :name name-string
 620       :lisp-symbol name)))
 621
 622 (defmethod print-object ((object movitz-symbol) stream)
 623   (typecase (movitz-symbol-name object)
 624     (movitz-basic-vector
 625      (print-unreadable-object (object stream :type 'movitz-symbol)
 626        (format stream "|~A|"
 627                (map 'string #'identity
 628                     (slot-value (slot-value object 'name) 'symbolic-data))))
 629      object)
 630     (t (call-next-method))))
 631
 632 (defun movitz-read-and-intern-function-value (obj type)
 633   (assert (eq type 'word))
 634   (cond
 635    ((typep obj 'movitz-funobj)
 636     (movitz-intern obj))
 637    ((symbolp obj)
 638     (let ((x (movitz-env-named-function obj)))
 639       (check-type x movitz-funobj)
 640       (movitz-intern x)))
 641    (t (error "Illegal function value: ~S." obj))))
 642
 643 ;;; NIL
 644
 645
 646 (define-binary-class movitz-null (movitz-symbol) ())
 647
 648 (defun make-movitz-nil ()
 649   (make-instance 'movitz-null
 650     :name (symbol-name nil)
 651     :value nil
 652     :plist nil
 653     :hash-key 0
 654     :flags '(:constant-variable)))
 655
 656 (defmethod movitz-intern ((object movitz-null) &optional (type 'word))
 657   (assert (eq 'word type))
 658   (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 ;;; Compiled funobj
 667
 668 (define-binary-class movitz-funobj (movitz-heap-object-other)
 669   ((type
 670     :binary-type other-type-byte
 671     :initform :funobj)
 672    (funobj-type
 673     :binary-type (define-enum movitz-funobj-type (u8)
 674                    :standard-function 0
 675                    :generic-function 1
 676                    :method-function 2)
 677     :initform :standard-function
 678     :accessor movitz-funobj-type)
 679    (debug-info
 680     ;; Bits 0-4: The value of the start-stack-frame-setup label.
 681     ;; Bit    5: The code-vector's uses-stack-frame-p.
 682     :binary-type 'lu16
 683     :initform 0)
 684    (code-vector
 685     :binary-type code-vector-word
 686     :initform 'muerte::no-code-vector
 687     :initarg :code-vector
 688     :map-binary-write 'movitz-intern-code-vector
 689     :map-binary-read-delayed 'movitz-word-code-vector
 690     :accessor movitz-funobj-code-vector)
 691    (code-vector%1op
 692     :binary-type code-pointer
 693     :initform 'muerte::trampoline-funcall%1op
 694     :initarg :code-vector%1op
 695     :map-binary-write 'movitz-intern-code-vector
 696     :accessor movitz-funobj-code-vector%1op)
 697    (code-vector%2op
 698     :binary-type code-pointer
 699     :initform 'muerte::trampoline-funcall%2op
 700     :initarg :code-vector%2op
 701     :map-binary-write 'movitz-intern-code-vector
 702     :accessor movitz-funobj-code-vector%2op)
 703    (code-vector%3op
 704     :binary-type code-pointer
 705     :initform 'muerte::trampoline-funcall%3op
 706     :initarg :code-vector%3op
 707     :map-binary-write 'movitz-intern-code-vector
 708     :accessor movitz-funobj-code-vector%3op)
 709    (lambda-list
 710     :binary-type word
 711     :map-binary-write 'movitz-read-and-intern
 712     :map-binary-read-delayed 'movitz-word
 713     :reader movitz-funobj-lambda-list
 714     :initarg :lambda-list)
 715    (name
 716     :binary-type word
 717     :map-binary-write 'movitz-read-and-intern
 718     :map-binary-read-delayed 'movitz-word
 719     :accessor movitz-funobj-name
 720     :initarg :name)
 721    (num-jumpers                         ; how many of the first constants are jumpers.
 722     :binary-type lu16                   ; 14 bits, the lower 16 bits of a fixnum.
 723     :initform 0                         ; This, in order to see this as a fixnum while
 724     :accessor movitz-funobj-num-jumpers ; GC scanning.
 725     :initarg :num-jumpers
 726     :map-binary-write (lambda (x &optional type)
 727                         (declare (ignore type))
 728                         (check-type x (unsigned-byte 14))
 729                         (* x +movitz-fixnum-factor+))
 730     :map-binary-read (lambda (x &optional type)
 731                        (declare (ignore type))
 732                        (assert (zerop (ldb (byte 2 0) x)))
 733                        (/ x +movitz-fixnum-factor+)))
 734    (num-constants
 735     :binary-type lu16
 736     :initform 0
 737     :initarg :num-constants
 738     :accessor movitz-funobj-num-constants)
 739    ;; The funobj's constants follow here..
 740    (constant0
 741     :binary-type :label)
 742    ;; A standard-generic-function will have three constants:
 743    ;; The class, the slots, and the discriminating-function.
 744    (const-list                          ;
 745     ;; :initform ()
 746     :initarg :const-list
 747     :accessor movitz-funobj-const-list)
 748    (jumpers-map
 749     :initarg :jumpers-map
 750     :accessor movitz-funobj-jumpers-map)
 751    (symbolic-name
 752     :initarg :symbolic-name
 753     :accessor movitz-funobj-symbolic-name)
 754    (symbolic-code
 755     :initarg :symbolic-code
 756     :accessor movitz-funobj-symbolic-code)
 757    (symtab
 758     :initform nil
 759     :accessor movitz-funobj-symtab)
 760    (borrowed-bindings
 761     :initarg :borrowed-bindings
 762     :initform nil
 763     :accessor borrowed-bindings)
 764    (function-envs
 765     :accessor function-envs)
 766    (funobj-env
 767     :initarg :funobj-env
 768     :accessor funobj-env)
 769    (extent
 770     :initarg :extent
 771     :initform :unused
 772     :accessor movitz-funobj-extent)
 773    (allocation
 774     :accessor movitz-allocation)
 775    (usage
 776     :initform nil
 777     :accessor movitz-funobj-usage)
 778    (sub-function-binding-usage          ; a plist used during lexical analysis
 779     :initform nil
 780     :accessor sub-function-binding-usage)
 781    (entry-protocol
 782     :initform :default
 783     :initarg :entry-protocol
 784     :reader funobj-entry-protocol)
 785    (headers-on-stack-frame-p
 786     :initform nil
 787     :accessor headers-on-stack-frame-p))
 788   (:slot-align type #.+other-type-offset+))
 789
 790 (defmethod write-binary-record ((obj movitz-funobj) stream)
 791   (declare (special *record-all-funobjs*))
 792   (assert (movitz-funobj-code-vector obj) (obj)
 793     "No code-vector for funobj named ~S." (movitz-funobj-name obj))
 794   #+ignore
 795   (assert (= (movitz-funobj-num-constants obj)
 796              (length (movitz-funobj-const-list obj))))
 797   (+ (call-next-method)                 ; header
 798      (loop for data in (movitz-funobj-const-list obj)
 799          as pos upfrom 0
 800          summing (if (>= pos (movitz-funobj-num-jumpers obj))
 801                      (write-binary 'word stream (movitz-intern data))
 802                    (let ((x (cdr (assoc data (movitz-funobj-symtab obj)))))
 803                      (assert (integerp x) ()
 804                        "Unable to resolve jumper ~S." data)
 805                      (write-binary 'u32 stream
 806                                    (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj)))))))))
 807
 808 (defmethod print-object ((object movitz-funobj) stream)
 809   (print-unreadable-object (object stream :type t :identity t)
 810     (write (movitz-print (movitz-funobj-name object)) :stream stream)))
 811
 812 (defmethod sizeof ((obj movitz-funobj))
 813   (+ (sizeof (find-binary-type 'movitz-funobj))
 814      (* (movitz-funobj-num-constants obj)
 815         (sizeof 'word))))
 816
 817 (defun make-movitz-funobj (lambda-list &key (name ""))
 818   (check-type name (or symbol cons))
 819   (make-instance 'movitz-funobj
 820     :lambda-list lambda-list
 821     :name name))
 822
 823 (defun funobj-name (x)
 824   (typecase x
 825     (movitz-funobj
 826      (movitz-funobj-name x))))
 827
 828 ;;;
 829
 830 (define-binary-class movitz-funobj-standard-gf (movitz-funobj)
 831   ;; This class is binary congruent with movitz-funobj.
 832   ((type
 833     :binary-type other-type-byte)
 834    (funobj-type
 835     :binary-type movitz-funobj-type
 836     :initform :generic-function)
 837    (debug-info
 838     ;; Bits 0-4: The value of the start-stack-frame-setup label.
 839     :binary-type 'lu16
 840     :initform 0)
 841    (code-vector
 842     :binary-type code-vector-word
 843     :initform 'muerte::standard-gf-dispatcher
 844     :map-binary-write 'movitz-intern-code-vector
 845     :map-binary-read-delayed 'movitz-word-code-vector)
 846    (code-vector%1op
 847     :initform 'muerte::standard-gf-dispatcher%1op
 848     :binary-type code-pointer
 849     :map-binary-write 'movitz-intern-code-vector)
 850    (code-vector%2op
 851     :initform 'muerte::standard-gf-dispatcher%2op
 852     :binary-type code-pointer
 853     :map-binary-write 'movitz-intern-code-vector)
 854    (code-vector%3op
 855     :initform 'muerte::standard-gf-dispatcher%3op
 856     :binary-type code-pointer
 857     :map-binary-write 'movitz-intern-code-vector)
 858    (lambda-list
 859     :binary-type word
 860     :map-binary-write 'movitz-read-and-intern
 861     :map-binary-read-delayed 'movitz-word)
 862    (name
 863     :binary-type word
 864     :map-binary-write 'movitz-read-and-intern
 865     :map-binary-read-delayed 'movitz-word)
 866    (num-jumpers
 867     :binary-type lu16
 868     :initform 0
 869     :accessor movitz-funobj-num-jumpers
 870     :map-binary-write (lambda (x &optional type)
 871                        (declare (ignore type))
 872                        (check-type x (unsigned-byte 14))
 873                        (* x +movitz-fixnum-factor+))
 874     :map-binary-read (lambda (x &optional type)
 875                        (declare (ignore type))
 876                        (assert (zerop (ldb (byte 2 0) x)))
 877                        (/ x +movitz-fixnum-factor+)))
 878    (num-constants
 879     :binary-type lu16
 880     :initform (/ (- (sizeof 'movitz-funobj-standard-gf)
 881                     (sizeof 'movitz-funobj))
 882                  4))                    ; XXXXXXX MUST MATCH NUMBER OF WORDS BELOW XXXXXXXXXXX
 883    (standard-gf-function                ; a movitz-funobj which is called by dispatcher (in code-vector)
 884     :accessor standard-gf-function
 885     :initarg :function
 886     :initform 'muerte::unbound-function
 887     :binary-type word
 888     :map-binary-write 'movitz-read-and-intern-function-value)
 889    (num-required-arguments
 890     :initarg :num-required-arguments
 891     :binary-type word
 892     :map-binary-write 'movitz-read-and-intern
 893     :map-binary-read-delayed 'movitz-word-and-print)
 894    (classes-to-emf-table
 895     :initarg :classes-to-emf-table
 896     :binary-type word
 897     :map-binary-write 'movitz-read-and-intern
 898     :map-binary-read-delayed 'movitz-word-and-print)
 899    (eql-specializer-table
 900     :initform nil
 901     :initarg :eql-specializer-table
 902     :binary-type word
 903     :map-binary-write 'movitz-read-and-intern
 904     :map-binary-read-delayed 'movitz-word-and-print)
 905    (standard-gf-class
 906     :accessor standard-gf-class
 907     :initarg :class
 908     :binary-type word
 909     :map-binary-write 'movitz-read-and-intern
 910     :map-binary-read-delayed 'movitz-word)
 911    (standard-gf-slots
 912     :accessor standard-gf-slots
 913     :initarg :slots
 914     :binary-type word
 915     :map-binary-write 'movitz-read-and-intern
 916     :map-binary-read-delayed 'movitz-word)
 917    (plist
 918     :initform nil))
 919   (:slot-align type #.+other-type-offset+))
 920
 921 (defmethod movitz-funobj-const-list ((funobj movitz-funobj-standard-gf))
 922   nil)
 923
 924 (defun make-standard-gf (class slots &key lambda-list (name "unnamed")
 925                                           (function 'muerte::unbound-function)
 926                                           num-required-arguments
 927                                           classes-to-emf-table)
 928   (make-instance 'movitz-funobj-standard-gf
 929     :lambda-list lambda-list
 930     :name name
 931     :class class
 932     :slots slots
 933     :function function
 934     :num-required-arguments num-required-arguments
 935     :classes-to-emf-table classes-to-emf-table))
 936
 937 ;;;
 938
 939 (define-binary-class movitz-struct (movitz-heap-object-other)
 940   ((type
 941     :binary-type other-type-byte
 942     :initform :defstruct)
 943    (pad :binary-lisp-type 1)
 944    (length
 945     :binary-type lu16
 946     :initarg :length
 947     :accessor movitz-struct-length
 948     :map-binary-write (lambda (x &optional type)
 949                         (declare (ignore type))
 950                         (check-type x (unsigned-byte 14))
 951                         (* x 4))
 952     :map-binary-read (lambda (x &optional type)
 953                        (declare (ignore type))
 954                        (assert (zerop (mod x 4)))
 955                        (truncate x 4)))
 956    (class
 957     :binary-type word
 958     :map-binary-write 'movitz-intern
 959     :map-binary-read-delayed 'movitz-word
 960     :reader movitz-struct-class
 961     :initarg :class)
 962    (slot0 :binary-lisp-type :label)     ; the slot values follows here.
 963    (slot-values
 964     :initform '()
 965     :initarg :slot-values
 966     :accessor movitz-struct-slot-values))
 967   (:slot-align type #.+other-type-offset+))
 968
 969 (defmethod update-movitz-object ((movitz-struct movitz-struct) lisp-struct)
 970   (declare (ignore lisp-struct))
 971   (values))
 972
 973 (defmethod sizeof ((obj movitz-struct))
 974   (+ (sizeof 'movitz-struct)
 975      (* 4 (length (movitz-struct-slot-values obj)))))
 976
 977 (defmethod write-binary-record ((obj movitz-struct) stream)
 978   (+ (call-next-method)                 ; header
 979      (loop for slot-value in (movitz-struct-slot-values obj)
 980          for slot-word = (movitz-read-and-intern slot-value 'word)
 981          summing (write-binary 'word stream slot-word))))
 982
 983 (defmethod read-binary-record ((type-name (eql 'movitz-struct)) stream &key)
 984   (let ((object (call-next-method)))
 985     (setf (movitz-struct-slot-values object)
 986       (loop for i from 1 to (movitz-struct-length object)
 987           collect
 988             (let ((word (read-binary 'word stream)))
 989               (with-image-stream-position-remembered ()
 990                 (movitz-word word)))))
 991     object))
 992
 993 (defmethod print-object ((object movitz-struct) stream)
 994   (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 (defun movitz-sxhash (object)
1004   "Must match the SXHASH function in :cl/hash-tables."
1005   (typecase object
1006     (movitz-null
1007      0)
1008     (movitz-symbol
1009      (movitz-symbol-hash-key object))
1010     (movitz-string
1011      (let* ((object (movitz-print object))
1012             (result (if (not (> (length object) 8))
1013                         0
1014                       (char-code (char-upcase (aref object (- (length object) 3)))))))
1015        (dotimes (i (min 8 (length object)))
1016          (incf result result)
1017          (incf result
1018                (if (evenp i)
1019                    (char-code (char-upcase (aref object i)))
1020                  (* 7 (char-code (char-upcase (aref object i)))))))
1021        (ldb (byte 16 0)
1022             (+ (* #x10ad (length object))
1023                result))))
1024     (movitz-fixnum
1025      (movitz-fixnum-value object))
1026     (t (warn "Don't know how to take SXHASH of ~S." object)
1027        0)))
1028
1029 (defvar *hash-table-size-factor* 5/4)
1030
1031 (defun find-movitz-hash-table-test (lisp-hash)
1032   (ecase (hash-table-test lisp-hash)
1033     ((eq #+clisp ext:fasthash-eq)
1034      (values 'muerte.cl:eq 'muerte::sxhash-eq))
1035     ((eql #+clisp ext:fasthash-eql)
1036      (values 'muerte.cl:eql 'muerte.cl::sxhash))
1037     ((equal #+clisp ext:fasthash-equal)
1038      (values 'muerte.cl:equal 'muerte.cl::sxhash))))
1039
1040 (defun make-movitz-hash-table (lisp-hash)
1041   (let* ((undef (movitz-read +undefined-hash-key+))
1042          (hash-count (hash-table-count lisp-hash))
1043          (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count)
1044                                             *hash-table-size-factor*))))
1045          (bucket-data (make-array hash-size :initial-element undef)))
1046     (multiple-value-bind (hash-test hash-sxhash)
1047         (find-movitz-hash-table-test lisp-hash)
1048       (loop for key being the hash-keys of lisp-hash using (hash-value value)
1049           for movitz-key = (movitz-read key)
1050           for movitz-value = (movitz-read value)
1051           do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size)
1052                  then (rem (+ 2 pos) hash-size)
1053                  until (eq undef (svref bucket-data pos))
1054 ;;;              do (warn "Hash collision at ~D of ~D: ~S ~S!"
1055 ;;;                       pos hash-size movitz-key (elt bucket-data pos))
1056 ;;;            finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value)
1057 ;;;            finally (when (equal "NIL" key)
1058 ;;;                      (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos))
1059                  finally (setf (svref bucket-data pos) movitz-key
1060                                (svref bucket-data (1+ pos)) movitz-value)))
1061       (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data))
1062              (lh (make-instance 'movitz-struct
1063                    :class (muerte::movitz-find-class 'muerte::hash-table)
1064                    :length 4
1065                    :slot-values (list hash-test ; test-function
1066                                       bucket
1067                                       hash-sxhash
1068                                       hash-count))))
1069         lh))))
1070
1071 (defmethod update-movitz-object ((movitz-hash movitz-struct) (lisp-hash hash-table))
1072   "Keep <movitz-hash> in sync with <lisp-hash>."
1073   (assert (= 4 (length (movitz-struct-slot-values movitz-hash))))
1074   (let* ((undef (movitz-read +undefined-hash-key+))
1075          (old-bucket (second (movitz-struct-slot-values movitz-hash)))
1076          (hash-count (hash-table-count lisp-hash))
1077          (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count)
1078                                             *hash-table-size-factor*))))
1079          (bucket-data (or (and old-bucket
1080                                (= (length (movitz-vector-symbolic-data old-bucket))
1081                                   hash-size)
1082                                (fill (movitz-vector-symbolic-data old-bucket) undef))
1083                           (make-array hash-size :initial-element undef))))
1084     (multiple-value-bind (hash-test hash-sxhash)
1085         (find-movitz-hash-table-test lisp-hash)
1086       (loop for key being the hash-keys of lisp-hash using (hash-value value)
1087           for movitz-key = (movitz-read key)
1088           for movitz-value = (movitz-read value)
1089           do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size)
1090                  then (rem (+ 2 pos) hash-size)
1091                  until (eq undef (svref bucket-data pos))
1092 ;;;            do (warn "Hash collision at ~D of ~D: ~S ~S!"
1093 ;;;                     pos hash-size movitz-key (elt bucket-data pos))
1094 ;;;            finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value)
1095 ;;;            finally (when (equal "NIL" key)
1096 ;;;                      (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos))
1097                  finally
1098                    (setf (svref bucket-data pos) movitz-key
1099                          (svref bucket-data (1+ pos)) movitz-value)))
1100       (setf (first (movitz-struct-slot-values movitz-hash)) hash-test
1101             (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data)
1102             (third (movitz-struct-slot-values movitz-hash)) hash-sxhash
1103             (fourth (movitz-struct-slot-values movitz-hash)) hash-count)
1104       movitz-hash)))
1105
1106 ;;;
1107
1108 ;;;(unless (typep *movitz-nil* 'movitz-nil)
1109 ;;;  (warn "Creating new *MOVITZ-NIL* object!")
1110 ;;;  (setf *movitz-nil* (make-movitz-nil)))
1111
1112
1113 (define-binary-class gate-descriptor ()
1114   ((offset-low
1115     :binary-type u16
1116     :initarg offset-low)
1117    (selector
1118     :binary-type u16
1119     :initarg selector)
1120    (count
1121     :binary-type u8
1122     :initarg count)
1123    (access
1124     :initarg access
1125     :binary-type (define-bitfield gate-descriptor-access (u8)
1126                    (((:numeric privilege-level 2 5))
1127                     ((:enum :byte (5 0)) :task         #x5
1128                                          :interrupt    #xe
1129                                          :interrupt-16 #x6
1130                                          :trap         #xf
1131                                          :trap-16      #x7)
1132                     ((:bits) segment-present 7))))
1133    (offset-high
1134     :binary-type u16
1135     :initarg offset-high)))
1136
1137 (defun make-gate-descriptor (type offset &key (segment-selector 0) (privilege 0) (count 0))
1138   (check-type offset (unsigned-byte 32))
1139   (check-type count (integer 0 31))
1140   (check-type privilege (integer 0 3))
1141   (make-instance 'gate-descriptor
1142     'offset-low (ldb (byte 16 0) offset)
1143     'offset-high (ldb (byte 16 16) offset)
1144     'selector segment-selector
1145     'count (ldb (byte 5 0) count)
1146     'access (list `(privilege-level . ,privilege)
1147                   type
1148                   'segment-present)))
1149
1150 (defun map-interrupt-trampolines-to-idt (trampolines type)
1151   (check-type trampolines vector)
1152   (assert (eq type 'word))
1153   (let* ((byte-list
1154           (with-binary-output-to-list (bytes)
1155             (loop for trampoline across trampolines
1156                 as exception-vector upfrom 0
1157                 do (let* ((trampoline-address (movitz-intern (find-primitive-function trampoline)))
1158                           (symtab (movitz-env-get trampoline :symtab))
1159                           (trampoline-offset (cdr (assoc exception-vector symtab))))
1160                      (assert symtab ()
1161                        "No symtab for exception trampoline ~S." trampoline)
1162                      (write-binary-record
1163                       (make-gate-descriptor ':interrupt
1164                                             (+ (slot-offset 'movitz-basic-vector 'data)
1165                                                trampoline-address
1166                                                trampoline-offset)
1167                                             :segment-selector (* 3 8))
1168                       bytes))))))
1169     (let ((l32 (merge-bytes byte-list 8 32)))
1170       (movitz-intern (make-movitz-vector (length l32)
1171                                          :element-type '(unsigned-byte 32)
1172                                          :initial-contents l32)))))
1173
1174
1175 ;;; std-instance
1176
1177 (define-binary-class movitz-std-instance (movitz-heap-object-other)
1178   ((type
1179     :binary-type other-type-byte
1180     :initform :std-instance)
1181    (pad :binary-lisp-type 3)
1182    (dummy
1183     :binary-type word
1184     :initform nil
1185     :map-binary-write 'movitz-read-and-intern
1186     :map-binary-read-delayed 'movitz-word)
1187    (class
1188     :binary-type word
1189     :map-binary-write 'movitz-intern
1190     :map-binary-read-delayed 'movitz-word
1191     :initarg :class
1192     :accessor movitz-std-instance-class)
1193    (slots
1194     :binary-type word
1195     :map-binary-write 'movitz-read-and-intern
1196     :map-binary-read-delayed 'movitz-word
1197     :initarg :slots
1198     :accessor movitz-std-instance-slots))
1199   (:slot-align type #.+other-type-offset+))
1200
1201 ;; (defmethod movitz-object-offset ((obj movitz-std-instance)) (- #x1e))
1202
1203 (defun make-movitz-std-instance (class slots)
1204   (make-instance 'movitz-std-instance
1205     :class (movitz-read class)
1206     :slots slots))
1207
1208 (defmethod print-object ((object movitz-std-instance) stream)
1209   (print-unreadable-object (object stream :identity t)
1210     (format stream "movitz-obj")
1211     (when (not (boundp '*movitz-obj-no-recurse*))
1212       (let ((*print-level* nil)
1213             (*movitz-obj-no-recurse* t))
1214         (declare (special *movitz-obj-no-recurse*))
1215         (write-char #\space stream)
1216         (write (aref (movitz-print (slot-value object 'slots)) 0)
1217                :stream stream))))
1218   object)
1219
1220 ;;;;
1221
1222 (define-binary-class movitz-bignum (movitz-heap-object-other)
1223   ((type
1224     :binary-type other-type-byte
1225     :initform :bignum)
1226    (sign
1227     :binary-type u8
1228     :initarg :sign
1229     :accessor movitz-bignum-sign)
1230    (length
1231     :binary-type lu16
1232     :initarg :length
1233     :accessor movitz-bignum-length
1234     :map-binary-write (lambda (x &optional type)
1235                         (declare (ignore type))
1236                         (check-type x (unsigned-byte 14))
1237                         (* x 4))
1238     :map-binary-read (lambda (x &optional type)
1239                        (declare (ignore type))
1240                        (assert (zerop (mod x 4)))
1241                        (truncate x 4)))
1242    (bigit0 :binary-type :label)
1243    (value
1244     :initarg :value
1245     :accessor movitz-bignum-value))
1246   (:slot-align type #.+other-type-offset+))
1247
1248 (defmethod write-binary-record ((obj movitz-bignum) stream)
1249   (let* ((num (movitz-bignum-value obj))
1250          (length (ceiling (integer-length (abs num)) 32)))
1251     (check-type length (unsigned-byte 16))
1252     (setf (movitz-bignum-length obj) length
1253           (movitz-bignum-sign obj) (if (minusp num) #xff #x00))
1254     (+ (call-next-method)               ; header
1255        (loop for b from 0 below length
1256            summing (write-binary 'lu32 stream (ldb (byte 32 (* b 32)) (abs num)))))))
1257
1258 (defun make-movitz-integer (value)
1259   (if (<= +movitz-most-negative-fixnum+ value +movitz-most-positive-fixnum+)
1260       (make-movitz-fixnum value)
1261     (make-instance 'movitz-bignum
1262       :value value)))
1263
1264 (defmethod sizeof ((obj movitz-bignum))
1265   (+ (sizeof 'movitz-bignum)
1266      (* 4 (ceiling (integer-length (abs (movitz-bignum-value obj))) 32))))
1267
1268 (defmethod update-movitz-object ((object movitz-bignum) lisp-object)
1269   (assert (= (movitz-bignum-value object) lisp-object))
1270   object)
1271
1272
1273 (defmethod read-binary-record ((type-name (eql 'movitz-bignum)) stream &key)
1274   (let* ((header (call-next-method))
1275          (x (loop for i from 0 below (movitz-bignum-length header)
1276                 summing (ash (read-binary 'u32 stream) (* i 32)))))
1277     (setf (movitz-bignum-value header)
1278       (ecase (movitz-bignum-sign header)
1279         (#x00 x)
1280         (#xff (- x))))
1281     header))
1282
1283 (define-binary-class movitz-ratio (movitz-heap-object-other)
1284   ((type
1285     :binary-type other-type-byte
1286     :initform :ratio)
1287    (dummy0
1288     :binary-type u8
1289     :initform 0)
1290    (dummy1
1291     :binary-type lu16
1292     :initform 0)
1293    (dummy2
1294     :binary-type word
1295     :initform 0)
1296    (numerator
1297     :binary-type word
1298     :map-binary-read-delayed 'movitz-word
1299     :map-binary-write 'movitz-read-and-intern)
1300    (denominator
1301     :binary-type word
1302     :map-binary-read-delayed 'movitz-word
1303     :map-binary-write 'movitz-read-and-intern)
1304    (value
1305     :reader movitz-ratio-value
1306     :initarg :value))
1307   (:slot-align type #.+other-type-offset+))
1308
1309 (defmethod write-binary-record ((obj movitz-ratio) stream)
1310   (declare (ignore stream))
1311   (let ((value (movitz-ratio-value obj)))
1312     (check-type value ratio)
1313     (setf (slot-value obj 'numerator) (numerator value)
1314           (slot-value obj 'denominator) (denominator value))
1315     (call-next-method)))
1316
1317
1318 (defmethod update-movitz-object ((object movitz-ratio) lisp-object)
1319   (assert (= (movitz-ratio-value object) lisp-object))
1320   object)
1321
1322 (defmethod update-movitz-object ((object movitz-ratio) (lisp-object float))
1323   (assert (= (movitz-ratio-value object) (rationalize lisp-object)))
1324   object)
1325
1326 (defmethod print-object ((x movitz-ratio) stream)
1327   (print-unreadable-object (x stream :type t)
1328     (format stream "~D" (slot-value x 'value)))
1329   x)
1330