1 ;;;;------------------------------------------------------------------
3 ;;;; Copyright (C) 2001,2000, 2002-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway.
6 ;;;; Filename: image.lisp
7 ;;;; Description: Construction of Movitz images.
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.
12 ;;;; $Id: image.lisp,v 1.113 2007/04/01 18:18:26 ffjeld Exp $
14 ;;;;------------------------------------------------------------------
18 (define-binary-class movitz-run-time-context
(movitz-heap-object)
19 ((run-time-context-start :binary-type
:label
) ; keep this at the top.
21 :binary-type other-type-byte
22 :initform
:run-time-context
)
25 (atomically-continuation
28 (raw-scratch0 ; A non-GC-root scratch register
31 (pointer-start :binary-type
:label
)
33 :binary-type code-vector-word
34 :map-binary-write
'movitz-intern-code-vector
35 :map-binary-read-delayed
'movitz-word-code-vector
36 :binary-tag
:primitive-function
)
38 :binary-type code-vector-word
40 :map-binary-write
'movitz-intern-code-vector
41 :map-binary-read-delayed
'movitz-word-code-vector
42 :binary-tag
:primitive-function
)
44 :binary-type code-vector-word
45 :map-binary-write
'movitz-intern-code-vector
46 :map-binary-read-delayed
'movitz-word-code-vector
47 :binary-tag
:primitive-function
)
48 (cons-commit-non-pointer
49 :binary-type code-vector-word
50 :map-binary-write
'movitz-intern-code-vector
51 :map-binary-read-delayed
'movitz-word-code-vector
52 :binary-tag
:primitive-function
)
54 :binary-type code-vector-word
55 :map-binary-write
'movitz-intern-code-vector
56 :map-binary-read-delayed
'movitz-word-code-vector
57 :binary-tag
:primitive-function
)
58 (cons-commit-non-header
59 :binary-type code-vector-word
60 :map-binary-write
'movitz-intern-code-vector
61 :map-binary-read-delayed
'movitz-word-code-vector
62 :binary-tag
:primitive-function
)
65 :binary-type code-vector-word
67 :map-binary-write
'movitz-intern-code-vector
68 :map-binary-read-delayed
'movitz-word-code-vector
69 :binary-tag
:primitive-function
)
70 ;; tag-specific class-of primitive-functions
71 (fast-class-of :binary-type
:label
)
72 (fast-class-of-even-fixnum ; 0000
73 :binary-type code-vector-word
74 :map-binary-write
'movitz-intern-code-vector
75 :map-binary-read-delayed
'movitz-word-code-vector
76 :binary-tag
:primitive-function
)
77 (fast-class-of-cons ; 1111
78 :binary-type code-vector-word
79 :map-binary-write
'movitz-intern-code-vector
80 :map-binary-read-delayed
'movitz-word-code-vector
81 :binary-tag
:primitive-function
)
82 (fast-class-of-character ; 2222
83 :binary-type code-vector-word
84 :map-binary-write
'movitz-intern-code-vector
85 :map-binary-read-delayed
'movitz-word-code-vector
86 :binary-tag
:primitive-function
)
87 (fast-class-of-tag3 ; 3333
88 :binary-type code-vector-word
89 :map-binary-write
'movitz-intern-code-vector
90 :map-binary-read-delayed
'movitz-word-code-vector
91 :binary-tag
:primitive-function
)
92 (fast-class-of-odd-fixnum ; 4444
93 :binary-type code-vector-word
94 :map-binary-write
'movitz-intern-code-vector
95 :map-binary-read-delayed
'movitz-word-code-vector
96 :binary-tag
:primitive-function
)
97 (fast-class-of-null ; 5555
98 :binary-type code-vector-word
99 :map-binary-write
'movitz-intern-code-vector
100 :map-binary-read-delayed
'movitz-word-code-vector
101 :binary-tag
:primitive-function
)
102 (fast-class-of-other ; 6666
103 :binary-type code-vector-word
104 :map-binary-write
'movitz-intern-code-vector
105 :map-binary-read-delayed
'movitz-word-code-vector
106 :binary-tag
:primitive-function
)
107 (fast-class-of-symbol ; 7777
108 :binary-type code-vector-word
109 :map-binary-write
'movitz-intern-code-vector
110 :map-binary-read-delayed
'movitz-word-code-vector
111 :binary-tag
:primitive-function
)
114 :map-binary-write
'movitz-intern-code-vector
115 :map-binary-read-delayed
'movitz-word-code-vector
116 :binary-tag
:primitive-function
117 :binary-type code-vector-word
)
118 (decode-keyargs-default
119 :map-binary-write
'movitz-intern-code-vector
120 :map-binary-read-delayed
'movitz-word-code-vector
121 :binary-tag
:primitive-function
122 :binary-type code-vector-word
)
124 :map-binary-write
'movitz-intern-code-vector
125 :map-binary-read-delayed
'movitz-word-code-vector
126 :binary-tag
:primitive-function
127 :binary-type code-vector-word
)
130 :binary-type code-vector-word
132 :map-binary-write
'movitz-intern-code-vector
133 :map-binary-read-delayed
'movitz-word-code-vector
134 :binary-tag
:primitive-function
)
136 :binary-type code-vector-word
138 :map-binary-write
'movitz-intern-code-vector
139 :map-binary-read-delayed
'movitz-word-code-vector
140 :binary-tag
:primitive-function
)
142 :binary-type code-vector-word
144 :map-binary-write
'movitz-intern-code-vector
145 :map-binary-read-delayed
'movitz-word-code-vector
146 :binary-tag
:primitive-function
)
148 :binary-type code-vector-word
150 :map-binary-write
'movitz-intern-code-vector
151 :map-binary-read-delayed
'movitz-word-code-vector
152 :binary-tag
:primitive-function
)
154 :binary-type code-vector-word
156 :map-binary-write
'movitz-intern-code-vector
157 :map-binary-read-delayed
'movitz-word-code-vector
158 :binary-tag
:primitive-function
)
159 ;; primitive functions global constants
161 :binary-type code-vector-word
163 :map-binary-write
'movitz-intern-code-vector
164 :map-binary-read-delayed
'movitz-word-code-vector
165 :binary-tag
:primitive-function
)
166 (dynamic-variable-lookup
167 :map-binary-write
'movitz-intern-code-vector
168 :binary-tag
:primitive-function
169 :map-binary-read-delayed
'movitz-word-code-vector
170 :binary-type code-vector-word
)
171 (dynamic-variable-store
172 :map-binary-write
'movitz-intern-code-vector
173 :binary-tag
:primitive-function
174 :map-binary-read-delayed
'movitz-word-code-vector
175 :binary-type code-vector-word
)
177 :map-binary-write
'movitz-intern-code-vector
178 :binary-tag
:primitive-function
179 :map-binary-read-delayed
'movitz-word-code-vector
180 :binary-type code-vector-word
)
181 (dynamic-variable-install
182 :map-binary-write
'movitz-intern-code-vector
183 :binary-tag
:primitive-function
184 :map-binary-read-delayed
'movitz-word-code-vector
185 :binary-type code-vector-word
)
186 (dynamic-variable-uninstall
187 :map-binary-write
'movitz-intern-code-vector
188 :binary-tag
:primitive-function
189 :map-binary-read-delayed
'movitz-word-code-vector
190 :binary-type code-vector-word
)
192 :map-binary-write
'movitz-intern-code-vector
193 :binary-tag
:primitive-function
194 :map-binary-read-delayed
'movitz-word-code-vector
195 :binary-type code-vector-word
)
197 :map-binary-write
'movitz-intern-code-vector
198 :binary-tag
:primitive-function
199 :map-binary-read-delayed
'movitz-word-code-vector
200 :binary-type code-vector-word
)
202 :map-binary-write
'movitz-intern-code-vector
203 :binary-tag
:primitive-function
204 :map-binary-read-delayed
'movitz-word-code-vector
205 :binary-type code-vector-word
)
207 :map-binary-write
'movitz-intern-code-vector
208 :binary-tag
:primitive-function
209 :map-binary-read-delayed
'movitz-word-code-vector
210 :binary-type code-vector-word
)
212 :binary-type code-vector-word
213 :map-binary-write
'movitz-intern-code-vector
214 :map-binary-read-delayed
'movitz-word-code-vector
215 :binary-tag
:primitive-function
)
217 :binary-type code-vector-word
218 :map-binary-write
'movitz-intern-code-vector
219 :map-binary-read-delayed
'movitz-word-code-vector
220 :binary-tag
:primitive-function
)
222 :binary-type code-vector-word
224 :map-binary-write
'movitz-intern-code-vector
225 :map-binary-read-delayed
'movitz-word-code-vector
226 :binary-tag
:primitive-function
)
228 :binary-type code-vector-word
230 :map-binary-write
'movitz-intern-code-vector
231 :map-binary-read-delayed
'movitz-word-code-vector
232 :binary-tag
:primitive-function
)
233 (ensure-heap-cons-variable
234 :binary-type code-vector-word
236 :map-binary-write
'movitz-intern-code-vector
237 :map-binary-read-delayed
'movitz-word-code-vector
238 :binary-tag
:primitive-function
)
239 (fast-compare-two-reals
240 :binary-type code-vector-word
242 :map-binary-write
'movitz-intern-code-vector
243 :map-binary-read-delayed
'movitz-word-code-vector
244 :binary-tag
:primitive-function
)
245 (fast-compare-fixnum-real
246 :binary-type code-vector-word
248 :map-binary-write
'movitz-intern-code-vector
249 :map-binary-read-delayed
'movitz-word-code-vector
250 :binary-tag
:primitive-function
)
251 (fast-compare-real-fixnum
252 :binary-type code-vector-word
254 :map-binary-write
'movitz-intern-code-vector
255 :map-binary-read-delayed
'movitz-word-code-vector
256 :binary-tag
:primitive-function
)
257 (trampoline-cl-dispatch-1or2
258 :binary-type code-vector-word
260 :map-binary-write
'movitz-intern-code-vector
261 :map-binary-read-delayed
'movitz-word-code-vector
262 :binary-tag
:primitive-function
)
264 :binary-type code-vector-word
265 :map-binary-write
'movitz-intern-code-vector
266 :map-binary-read-delayed
'movitz-word-code-vector
267 :binary-tag
:primitive-function
)
268 (copy-funobj-code-vector-slots
269 :binary-type code-vector-word
270 :map-binary-write
'movitz-intern-code-vector
271 :map-binary-read-delayed
'movitz-word-code-vector
272 :binary-tag
:primitive-function
)
275 (boolean-one :binary-type
:label
)
276 (not-nil ; not-nil, t-symbol and not-not-nil must be consecutive.
279 :map-binary-write
'movitz-read-and-intern
280 :map-binary-read-delayed
'movitz-word
)
281 (boolean-zero :binary-type
:label
)
285 :map-binary-write
'movitz-intern
286 :map-binary-read-delayed
'movitz-word
)
290 :map-binary-write
'movitz-read-and-intern
291 :map-binary-read-delayed
'movitz-word
)
292 ;; (null-cons :binary-type :label)
294 :binary-type movitz-symbol
295 :reader movitz-run-time-context-null-symbol
296 :initarg
:null-symbol
)
299 :initform
'muerte
::complicated-eql
301 :binary-tag
:global-function
302 :map-binary-write
'movitz-intern
303 :map-binary-read-delayed
'movitz-word
)
306 :binary-tag
:global-function
307 :map-binary-read-delayed
'movitz-word
308 :map-binary-write
'movitz-intern
)
321 :map-binary-write
'movitz-intern
322 :map-binary-read-delayed
'movitz-word
324 :accessor run-time-context-class
)
327 :map-binary-write
'movitz-read-and-intern
328 :map-binary-read-delayed
'movitz-word
330 :initform
#(:init nil
)
331 :accessor run-time-context-slots
)
334 :map-binary-read-delayed
'movitz-word
335 :map-binary-write
'movitz-read-and-intern
336 :initform
'muerte
::unwind-protect-tag
)
339 :map-binary-read-delayed
'movitz-word
340 :map-binary-write
'movitz-read-and-intern
341 :initform
'muerte
::restart-protect-tag
)
344 :map-binary-read-delayed
'movitz-word
345 :map-binary-write
'movitz-read-and-intern
347 (stack-bottom ; REMEMBER BOCHS!
350 (stack-top ; stack-top must be right after stack-bottom
351 :binary-type word
; in order for the bound instruction to work.
354 :initform
'muerte.cl
:+
356 :binary-tag
:global-function
357 :map-binary-write
'movitz-intern
358 :map-binary-read-delayed
'movitz-word
)
362 :map-binary-write
(lambda (x type
)
363 (declare (ignore type
))
364 (movitz-read-and-intern (funcall 'muerte
::movitz-find-class x
)
366 :map-binary-read-delayed
'movitz-word
)
369 ;; :accessor movitz-run-time-context-copy-funobj
370 :initform
'muerte
::copy-funobj
371 :map-binary-write
(lambda (name type
)
372 (declare (ignore type
))
373 (movitz-intern (movitz-env-named-function name
))))
376 (classes ; A vector of class meta-objects.
377 :initform nil
; The first element is the map of corresponding names
379 :map-binary-write
(lambda (x type
)
380 (declare (ignore x type
))
381 (let ((map (image-classes-map *image
*)))
382 (movitz-read-and-intern
386 (funcall 'muerte
::movitz-find-class x
))
389 :map-binary-read-delayed
'movitz-word
)
390 (physical-address-offset
392 :initform
(image-ds-segment-base *image
*))
396 :map-binary-write
'movitz-read-and-intern
397 :map-binary-read-delayed
(lambda (x type
)
398 (declare (ignore x type
))
400 (allow-other-keys-symbol
402 :initform
:allow-other-keys
403 :map-binary-write
'movitz-read-and-intern
404 :map-binary-read-delayed
(lambda (x type
)
405 (declare (ignore x type
))
410 :map-binary-read-delayed
'movitz-word
)
411 (complicated-class-of
413 :binary-tag
:global-function
414 :map-binary-read-delayed
'movitz-word
415 :map-binary-write
'movitz-intern
)
419 :map-binary-write
'movitz-read-and-intern
420 :map-binary-read-delayed
(lambda (x type
)
421 (declare (ignore x type
))
425 :map-binary-write
'movitz-intern
426 :map-binary-read-delayed
'movitz-word
427 :initarg
:exception-handlers
428 :accessor movitz-run-time-context-exception-handlers
)
429 (interrupt-descriptor-table
431 :accessor movitz-run-time-context-interrupt-descriptor-table
432 :initform
(make-array 256 :initial-element
'muerte
::default-interrupt-trampoline
)
433 :map-binary-read-delayed
'movitz-word
434 :map-binary-write
'map-interrupt-trampolines-to-idt
)
436 :binary-type word
; Fixnum
439 :binary-type
#.
(* 4 +movitz-multiple-values-limit
+)))
440 (:slot-align null-symbol -
5))
442 (defun atomically-continuation-simple-pf (pf-name)
443 (ldb (byte 32 0) (global-constant-offset pf-name
))
445 (bt:enum-value
'movitz
::atomically-status
446 (list* :restart-primitive-function
447 (cons :reset-status-p
448 (if reset-status-p
1 0))
452 (truncate (+ (tag :null
)
453 (bt:slot-offset
'movitz-run-time-context
454 (intern (symbol-name pf-name
)
459 (defun atomically-status-jumper-fn (reset-status-p &rest registers
)
460 (assert (not reset-status-p
))
461 (assert (null registers
))
463 (assert (= 0 (mod jumper
4)))
464 (bt:enum-value
'movitz
::atomically-status
465 (list* :restart-jumper
466 (cons :reset-status-p
467 (if reset-status-p
1 0))
468 (cons :data
(truncate jumper
4))
471 (defmethod movitz-object-offset ((obj movitz-run-time-context
)) 0)
473 (defun global-constant-offset (slot-name)
474 (check-type slot-name symbol
)
475 (let ((slot-name (find-symbol (symbol-name slot-name
) :movitz
)))
477 (if (not (eq slot-name
'unbound-function
))
478 (slot-offset 'movitz-run-time-context slot-name
)
479 (+ (slot-offset 'movitz-run-time-context
'null-symbol
)
480 (slot-offset 'movitz-symbol
'function-value
)
483 (defun make-movitz-run-time-context ()
484 (make-instance 'movitz-run-time-context
485 :t-symbol
(movitz-read 't
)
486 :null-symbol
*movitz-nil
*))
488 (defclass movitz-image
()
490 :initarg
:ds-segment-base
492 :accessor image-ds-segment-base
)
494 :initarg
:cs-segment-base
496 :accessor image-cs-segment-base
)))
498 (defclass symbolic-image
(movitz-image)
500 :accessor image-object-hash
) ; object => address
502 :accessor image-address-hash
) ; address => object
504 :accessor image-cons-pointer
)
506 :initform
(make-hash-table :test
#'eql
) ; lisp object => movitz object
507 :reader image-read-map-hash
)
508 (inverse-read-map-hash
509 :initform
(make-hash-table :test
#'eql
) ; lisp object => movitz object
510 :reader image-inverse-read-map-hash
)
513 :initform
(make-hash-table :test
#'eql
))
515 :initform
(make-global-movitz-environment)
516 :reader image-global-environment
)
517 (struct-slot-descriptions
518 :initform
(make-hash-table :test
#'eq
)
519 :accessor image-struct-slot-descriptions
)
521 :initarg
:start-address
522 :accessor image-start-address
)
523 (symbol-hash-key-counter
526 :accessor image-symbol-hash-key-counter
)
528 :accessor image-nil-word
)
531 :accessor image-nil-object
)
533 :accessor image-t-symbol
)
535 :accessor image-bootblock
)
537 :initarg
:movitz-modules
539 :accessor image-movitz-modules
)
541 :initarg
:movitz-features
542 :accessor image-movitz-features
)
544 :initarg
:called-functions
546 :accessor image-called-functions
)
548 :accessor image-toplevel-funobj
)
550 :accessor image-run-time-context
)
553 :accessor image-load-time-funobjs
)
554 (compile-time-variables
556 :accessor image-compile-time-variables
)
558 :initform
(make-hash-table :test
#'equal
)
559 :reader image-string-constants
)
561 :initform
(make-hash-table :test
#'equal
)
562 :reader image-cons-constants
)
564 :accessor image-multiboot-header
)
567 :accessor dump-count
)
569 :initform
(make-hash-table :test
#'equal
)
570 :initarg
:function-code-sizes
571 :reader function-code-sizes
)))
573 (defmethod image-classes-map ((image symbolic-image
))
574 '(muerte.cl
:null muerte.cl
:cons muerte.cl
:fixnum muerte.cl
:symbol
575 muerte.cl
:character muerte.cl
:function muerte.cl
:condition
576 muerte.cl
:integer muerte.cl
:ratio muerte.cl
:complex
577 muerte.cl
:vector muerte.cl
:string muerte.cl
:bit-vector muerte.cl
:array
578 muerte.cl
:class muerte.cl
:standard-class
579 muerte.cl
:standard-generic-function
580 muerte
:run-time-context
581 muerte.mop
:standard-effective-slot-definition
582 muerte.mop
:funcallable-standard-class
583 muerte
::basic-restart
584 muerte
::illegal-object
))
586 (defun class-object-offset (name)
587 (let ((name (translate-program name
:cl
:muerte.cl
)))
588 (+ (bt:slot-offset
'movitz-basic-vector
'data
)
589 (* 4 (1+ (or (position name
(image-classes-map *image
*))
590 (error "No class named ~S in class-map." name
)))))))
592 (defun unbound-value ()
593 (declare (special *image
*))
594 (movitz-read (slot-value (image-run-time-context *image
*)
595 'new-unbound-value
)))
598 (declare (special *image
*))
599 (- (image-nil-word *image
*)))
601 (defmethod image-intern-object ((image symbolic-image
) object
&optional
(size (sizeof object
)))
602 (assert ; sanity check on "other" storage-types.
603 (or (not (typep object
'movitz-heap-object-other
))
604 (and (= (- (tag :other
))
605 (slot-offset (type-of object
)
606 (first (binary-record-slot-names (type-of object
)))))
607 (= +other-type-offset
+ (slot-offset (type-of object
) 'type
))))
609 "The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object
))
612 (image-nil-word image
))
614 (+ (movitz-object-offset object
)
615 (or (gethash object
(image-object-hash image
))
616 (let* ((alignment (movitz-storage-alignment object
))
617 (new-ptr (if (= (movitz-storage-alignment-offset object
)
618 (mod (image-cons-pointer image
)
619 (movitz-storage-alignment object
)))
620 (image-cons-pointer image
)
621 (+ (image-cons-pointer image
)
622 (mod (- (image-cons-pointer image
))
624 (movitz-storage-alignment-offset object
)))))
625 (setf (gethash new-ptr
(image-address-hash image
)) object
626 (gethash object
(image-object-hash image
)) new-ptr
627 (image-cons-pointer image
) (+ new-ptr size
))
630 (defmethod image-memref ((image symbolic-image
) address
&optional
(errorp t
))
631 (let ((obj (gethash address
(image-address-hash image
) :nothing
)))
633 ((not (typep obj
'movitz-object
))
635 (error "Found non-movitz-object at image-address #x~X: ~A" address obj
))
639 (defmethod search-image ((image symbolic-image
) address
)
640 (loop for a downfrom
(logand address -
8) by
8
641 until
(gethash a
(image-address-hash image
))
642 finally
(let ((object (gethash a
(image-address-hash image
))))
643 (when (<= address
(+ a
(sizeof object
)))
644 ;; (warn "Found at ~X: ~S" a (gethash a (image-address-hash image)))
647 (defun search-image-funobj (address &optional
(*image
* *image
*))
648 (search-image-funobj-by-image *image
* address
))
650 (defmethod search-image-funobj-by-image ((image symbolic-image
) address
)
651 (let ((code-vector (search-image image
(1- address
))))
652 (unless (and (typep code-vector
'movitz-basic-vector
)
653 (eq :code
(movitz-vector-element-type code-vector
)))
654 (error "Not a code-vector at #x~8,'0X: ~S" address code-vector
))
655 (let ((offset (- address
(movitz-intern-code-vector code-vector
))))
656 (assert (not (minusp offset
)))
657 (format t
"~&;; Matched code-vector at #x~X with offset ~D.~%"
658 (image-intern-object image code-vector
)
660 (with-hash-table-iterator (next-object (image-object-hash *image
*))
661 (loop with more-objects and object
662 do
(multiple-value-setq (more-objects object
) (next-object))
664 when
(typecase object
666 (when (eq code-vector
(movitz-funobj-code-vector object
))
669 (when (eq code-vector
(movitz-symbol-value object
))
670 (movitz-print object
))))
673 (defun search-primitive-function (address &optional
(*image
* *image
*))
674 (let ((code-vector (search-image *image
* address
)))
675 (unless (and (typep code-vector
'movitz-basic-vector
)
676 (eq :u8
(movitz-vector-element-type code-vector
)))
677 (error "Not a code-vector at #x~8,'0X: ~S" address code-vector
))
678 (format t
"~&;; Code vector: #x~X" (movitz-intern code-vector
))
679 (loop for pf-name in
(binary-record-slot-names 'movitz-run-time-context
680 :match-tags
:primitive-function
)
681 when
(= (movitz-intern-code-vector code-vector
)
682 (binary-slot-value (image-run-time-context *image
*) pf-name
))
683 do
(format t
"~&;; #x~X matches global primitive-function ~W with offset ~D."
685 (- address
(movitz-intern-code-vector code-vector
)))
686 and collect pf-name
)))
690 (defun movitz-word (word &optional
(type 'word
))
691 "Return the movitz-object corresponding to (the integer) WORD."
692 (assert (eq type
'word
))
693 (movitz-word-by-image *image
* word
))
695 (defun movitz-word-and-print (word &optional
(type 'word
))
696 (movitz-print (movitz-word word type
)))
698 (defmethod movitz-word-by-image ((image symbolic-image
) word
)
699 (case (extract-tag word
)
702 (make-instance 'movitz-fixnum
:value
(fixnum-integer word
))))
704 (make-instance 'movitz-character
:char
(code-char (ldb (byte 8 8) word
))))
706 (image-nil-word image
))
707 (t (image-memref *image
* (logand word
#xfffffff8
) t
))))
709 (defun movitz-intern-code-vector (object &optional
(type 'code-vector-word
))
710 "Four ways to denote a code-vector: a vector is that vector,
711 a symbol is considered a primitive-function and the symbol-value is used,
712 a movitz-funobj is that funobj's code-vector,
713 a cons is an offset (the car) from some other code-vector (the cdr)."
714 (assert (member type
'(code-vector-word code-pointer
)))
716 ((or vector movitz-basic-vector
)
717 (+ 2 (movitz-intern object
)))
718 ((or symbol movitz-symbol
)
719 (let ((primitive-code-vector (movitz-symbol-value (movitz-read object
))))
720 (check-type primitive-code-vector movitz-basic-vector
)
721 (movitz-intern-code-vector primitive-code-vector type
)))
723 (movitz-intern-code-vector (movitz-funobj-code-vector object
) type
))
725 ;; a cons denotes an offset (car) from some funobj's (cdr) code-vector.
726 (check-type (car object
) integer
)
727 (check-type (cdr object
) movitz-funobj
)
728 (+ (car object
) (movitz-intern-code-vector (cdr object
) type
)))))
730 (defun movitz-intern-global-function (object &optional
(type 'word
))
731 (assert (eq type
'word
))
732 (check-type object symbol
)
733 (let ((x (movitz-env-named-function object
)))
734 (check-type x movitz-funobj
)
735 (movitz-intern x
'word
)))
737 (defun movitz-word-code-vector (word &optional
(type 'code-vector-word
))
738 (assert (eq type
'code-vector-word
))
739 (movitz-word (- word
+code-vector-word-offset
+)))
741 (defun copy-hash-table (x)
742 (let ((y (make-hash-table :test
(hash-table-test x
))))
743 (maphash (lambda (k v
)
744 (setf (gethash k y
) v
))
748 (defun make-initial-segment-descriptor-table ()
750 (let ((bt:*endian
* :little-endian
))
751 (merge-bytes (with-binary-output-to-list (octet-list)
752 (mapcar (lambda (init-args)
753 (write-binary 'segment-descriptor octet-list
754 (apply #'make-segment-descriptor init-args
)))
756 (:base
0 :limit
#xfffff
; 1: physical code
757 :type
14 :dpl
0 :flags
(s p d
/b g
))
758 (:base
0 :limit
#xfffff
; 2: physical data
759 :type
2 :dpl
3 :flags
(s p d
/b g
))
760 (:base
,(image-cs-segment-base *image
*) ; 3: logical code
762 :type
14 :dpl
0 :flags
(s p d
/b g
))
763 (:base
,(image-ds-segment-base *image
*) ; 4: logical data
765 :type
2 :dpl
0 :flags
(s p d
/b g
))
768 (movitz-read (make-movitz-vector (length u32-list
)
769 :initial-contents u32-list
770 :element-type
'(unsigned-byte 32)))))
773 (defun make-movitz-image (&rest init-args
&key start-address
&allow-other-keys
)
774 (let ((*image
* (apply #'make-instance
'symbolic-image
775 :nil-object
(make-movitz-nil)
776 :start-address start-address
777 :movitz-features
'(:movitz
)
780 (copy-hash-table (function-code-sizes *image
*))
781 (make-hash-table :test
#'equal
))
783 (setf (image-nil-word *image
*)
784 (+ 5 (- (slot-offset 'movitz-run-time-context
'null-symbol
)
785 (slot-offset 'movitz-run-time-context
'run-time-context-start
))
787 (image-ds-segment-base *image
*))))
788 (format t
"~&;; NIL value: #x~X.~%" (image-nil-word *image
*))
789 (assert (eq :null
(extract-tag (image-nil-word *image
*))) ()
790 "NIL value #x~X has tag ~D, but it must be ~D."
791 (image-nil-word *image
*)
792 (ldb (byte 3 0) (image-nil-word *image
*))
794 (setf (image-run-time-context *image
*) (make-movitz-run-time-context))
795 (setf (image-t-symbol *image
*) (movitz-read t
))
796 ;; (warn "NIL value: #x~X" (image-nil-word *image*))
799 (defun find-primitive-function (name)
800 "Given the NAME of a primitive function, look up
801 that function's code-vector."
803 (movitz-symbol-value (movitz-read name
))))
804 (unless (and code-vector
(not (eq 'unbound code-vector
)))
805 (cerror "Install an empty vector instead."
806 "Global constant primitive function ~S is not defined!" name
)
808 (setf (movitz-symbol-value (movitz-read name
))
810 (check-type code-vector movitz-basic-vector
)
813 (defun create-image (&rest init-args
814 &key
(init-file *default-image-init-file
*)
816 ;; (start-address #x100000)
818 (psetq *image
* (let ((*image
* (apply #'make-movitz-image
819 :start-address
#x100000
822 (movitz-compile-file init-file
))
826 #+allegro
(setf (sys:gsgc-parameter
:generation-spread
) 8)
827 #+allegro
(excl:gc
:tenure
)
828 #+allegro
(excl:gc t
)) ; We just thrashed a lot of tenured objects.
831 (defun set-file-position (stream position
&optional who
)
832 (declare (ignore who
))
833 (or (ignore-errors (file-position stream position
))
834 (let* ((end (file-position stream
:end
))
835 (diff (- position end
)))
837 (write-byte 0 stream
))
838 (assert (= position
(file-position stream
)))))
841 (defun dump-image (&key
(path *default-image-file
*) ((:image
*image
*) *image
*)
842 (multiboot-p t
) ignore-dump-count
(qemu-align-p t
))
843 "When <multiboot-p> is true, include a MultiBoot-compliant header in the image."
844 (when (and (not ignore-dump-count
)
845 (= 0 (dump-count *image
*)))
846 ;; This is a hack to deal with the fact that the first dump won't work
847 ;; because the packages aren't properly set up.
848 (format t
"~&;; Doing initiating dump..")
849 (dump-image :path path
:multiboot-p multiboot-p
:ignore-dump-count t
)
850 (assert (plusp (dump-count *image
*))))
851 (setf (movitz-symbol-value (movitz-read 'muerte
:*build-number
*))
852 (1+ *bootblock-build
*))
853 (when (eq 'unbound
(movitz-symbol-value (movitz-read 'muerte
::*initial-segment-descriptor-table
*)))
854 (setf (movitz-symbol-value (movitz-read 'muerte
::*initial-segment-descriptor-table
*))
855 (make-initial-segment-descriptor-table)))
856 (let ((handler (movitz-env-symbol-function 'muerte
::interrupt-default-handler
)))
857 (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image
*))
858 (movitz-read (make-array 256 :initial-element handler
))))
859 (setf (movitz-symbol-value (movitz-read 'muerte
::*setf-namespace
*))
860 (movitz-read (movitz-environment-setf-function-names *movitz-global-environment
*) t
))
861 (setf (run-time-context-class (image-run-time-context *image
*))
862 (muerte::movitz-find-class
'muerte
::run-time-context
))
863 ;; (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3))
864 (let ((load-address (image-start-address *image
*)))
865 (setf (image-cons-pointer *image
*) (- load-address
866 (image-ds-segment-base *image
*))
867 (image-address-hash *image
*) (make-hash-table :test
#'eq
)
868 (image-object-hash *image
*) (make-hash-table :test
#'eq
)
869 (image-multiboot-header *image
*) (make-instance 'multiboot-header
874 (assert (= load-address
(+ (image-intern-object *image
* (image-run-time-context *image
*))
875 (image-ds-segment-base *image
*))))
877 (assert (< (+ (image-intern-object *image
* (image-multiboot-header *image
*))
878 (sizeof (image-multiboot-header *image
*))
881 ;; make the toplevel-funobj
882 (unless (image-load-time-funobjs *image
*)
883 (warn "No top-level funobjs!"))
884 (setf (image-load-time-funobjs *image
*)
885 (stable-sort (copy-list (image-load-time-funobjs *image
*)) #'> :key
#'third
))
886 (let* ((toplevel-funobj (make-toplevel-funobj *image
*)))
887 (setf (image-toplevel-funobj *image
*) toplevel-funobj
888 #+ignore
((movitz-run-time-context-toplevel-funobj (image-run-time-context *image
*)) toplevel-funobj
))
889 (format t
"~&;; load-sequence:~%~<~A~>~%" (mapcar #'second
(image-load-time-funobjs *image
*)))
890 (movitz-intern toplevel-funobj
)
891 (let ((init-code-address (+ (movitz-intern-code-vector (movitz-funobj-code-vector toplevel-funobj
))
892 (image-cs-segment-base *image
*))))
893 (dolist (cf (image-called-functions *image
*))
894 (unless (typep (movitz-env-named-function (car cf
) nil
)
896 (warn "Function ~S is called (in ~S) but not defined." (car cf
) (cdr cf
))))
897 (maphash #'(lambda (symbol function-value
)
898 (let ((movitz-symbol (movitz-read symbol
)))
899 (if (typep function-value
'movitz-object
)
900 ;; (warn "SETTING ~A's funval to ~A"
901 ;; movitz-symbol function-value)
902 (setf (movitz-symbol-function-value movitz-symbol
)
904 #+ignore
(warn "fv: ~W" (movitz-macro-expander-function function-value
)))))
905 (movitz-environment-function-cells (image-global-environment *image
*)))
906 (let ((run-time-context (image-run-time-context *image
*)))
907 ;; pull in functions in run-time-context
908 (dolist (gcf-name (binary-record-slot-names 'movitz-run-time-context
:match-tags
:global-function
))
909 (let* ((gcf-movitz-name (movitz-read (intern (symbol-name gcf-name
)
911 (gcf-funobj (movitz-symbol-function-value gcf-movitz-name
)))
912 (setf (slot-value run-time-context gcf-name
) 0)
914 ((or (not gcf-funobj
)
915 (eq 'unbound gcf-funobj
))
916 (warn "Global constant function ~S is not defined!" gcf-name
))
917 (t (check-type gcf-funobj movitz-funobj
)
918 (setf (slot-value run-time-context gcf-name
)
920 ;; pull in primitive functions in run-time-context
921 (dolist (pf-name (binary-record-slot-names 'movitz-run-time-context
922 :match-tags
:primitive-function
))
923 (setf (slot-value run-time-context pf-name
)
924 (find-primitive-function (intern (symbol-name pf-name
) :muerte
))))
926 (loop for k being the hash-keys of
(movitz-environment-setf-function-names *movitz-global-environment
*)
928 do
(assert (eq (symbol-value v
) 'muerte
::setf-placeholder
))
929 do
(when (eq *movitz-nil
* (movitz-symbol-function-value (movitz-read v
)))
930 (warn "non-used setf: ~S" v
)))
932 (loop for
(symbol plist
) on
(movitz-environment-plists *movitz-global-environment
*) by
#'cddr
933 ;; do (warn "sp: ~S ~S" symbol plist)
934 do
(let ((x (movitz-read symbol
)))
938 (setf (movitz-plist x
)
939 (movitz-read (translate-program (loop for
(property value
) on plist by
#'cddr
940 unless
(member property
'(special constantp
))
941 append
(list property value
))
943 (t (warn "not a symbol for plist: ~S has ~S" symbol plist
)))))
944 ;; pull in global properties
945 (loop for
(var value
) on
(image-compile-time-variables *image
*) by
#'cddr
946 do
(let ((mname (movitz-read var
))
947 (mvalue (movitz-read value
)))
948 (setf (movitz-symbol-value mname
) mvalue
)))
949 (setf (movitz-symbol-value (movitz-read 'muerte
::*packages
*))
950 (movitz-read (make-packages-hash))))
951 (with-binary-file (stream path
954 :if-exists
:supersede
955 :if-does-not-exist
:create
)
956 (set-file-position stream
512) ; leave room for bootblock.
957 (let* ((stack-vector (make-instance 'movitz-basic-vector
962 (image-start (file-position stream
)))
963 (dump-image-core *image
* stream
) ; dump the kernel proper.
964 ;; make a stack-vector for the root run-time-context
965 (let* ((stack-vector-word
966 (let ((*endian
* :little-endian
))
967 (write-binary-record stack-vector stream
)
968 ;; Intern as _last_ object in image.
969 (movitz-intern stack-vector
)))
970 (image-end (file-position stream
))
971 (kernel-size (- image-end image-start
)))
972 (format t
"~&;; Kernel size: ~D octets.~%" kernel-size
)
975 ;; QEMU is rather stupid about "auto-detecting" floppy geometries.
976 (loop for qemu-geo in
'(320 360 640 720 720 820 840 1440 1440 1600 1640 1660 1760 2080 2240 2400
977 2880 2952 2988 3200 3200 3360 3444 3486 3520 3680 3840 5760 6240 6400 7040 7680)
978 as qemu-size
= (* qemu-geo
512)
979 do
(when (>= qemu-size image-end
)
980 (set-file-position stream
(1- qemu-size
) 'pad-image-tail
)
981 (write-byte #x0 stream
)
984 (cerror "Never mind, dump the image."
985 "No matching QEMU floppy geometry for size ~,2F MB." (/ image-end
(* 1024 1024)))))
986 (t (let ((align-image-size 512)) ; Ensure image is multiple of x octets
987 (unless (zerop (mod image-end align-image-size
))
988 (set-file-position stream
(+ image-end
(- (1- align-image-size
) (mod image-end
512)))
990 (write-byte #x0 stream
)))))
991 (format t
"~&;; Image file size: ~D octets.~%" image-end
)
992 ;; Write simple stage1 bootblock into sector 0..
993 (format t
"~&;; Dump count: ~D." (incf (dump-count *image
*)))
994 (flet ((global-slot-position (slot-name)
996 (image-nil-word *image
*)
997 (image-ds-segment-base *image
*)
998 (global-constant-offset slot-name
)
1000 (with-simple-restart (continue "Don't write a floppy bootloader.")
1001 (let ((bootblock (make-bootblock kernel-size
1003 init-code-address
)))
1004 (setf (image-bootblock *image
*) bootblock
)
1005 (set-file-position stream
0)
1006 (write-sequence bootblock stream
)))
1007 (let* ((stack-vector-address (+ (image-nil-word *image
*)
1008 (global-constant-offset 'stack-vector
)
1009 (image-ds-segment-base *image
*)))
1010 (stack-vector-position (- (+ stack-vector-address
512)
1012 (declare (ignore stack-vector-position
))
1013 #+ignore
(warn "stack-v-pos: ~S => ~S"
1014 stack-vector-position
1016 (set-file-position stream
(global-slot-position 'stack-vector
) 'stack-vector
)
1017 (write-binary 'word stream stack-vector-word
)
1018 (set-file-position stream
(global-slot-position 'stack-bottom
) 'stack-bottom
)
1019 (write-binary 'lu32 stream
(+ 8 (* 4 4096) ; cushion
1020 (- stack-vector-word
(tag :other
))))
1021 (set-file-position stream
(global-slot-position 'stack-top
) 'stack-top
)
1022 (write-binary 'lu32 stream
(+ 8 (- stack-vector-word
(tag :other
))
1023 (* 4 (movitz-vector-num-elements stack-vector
)))))
1024 (if (not multiboot-p
)
1025 (format t
"~&;; No multiboot header.")
1026 ;; Update multiboot header, symbolic and in the file..
1027 (let* ((mb (image-multiboot-header *image
*))
1028 (mb-address (+ (movitz-intern mb
)
1029 (slot-offset 'multiboot-header
'magic
)
1030 (image-ds-segment-base *image
*)))
1031 (mb-file-position (- (+ mb-address
512)
1033 (slot-offset 'multiboot-header
'magic
))))
1034 (when (< load-address
#x100000
)
1035 (warn "Multiboot load-address #x~x is below the 1MB mark."
1037 (when (> (+ mb-file-position
(sizeof mb
)) 8192)
1038 (warn "Multiboot header at position ~D is above the 8KB mark, ~
1039 this image will not be Multiboot compatible."
1040 (+ mb-file-position
(sizeof mb
))))
1041 (set-file-position stream mb-file-position
'multiboot-header
)
1042 ;; (format t "~&;; Multiboot load-address: #x~X." load-address)
1043 (setf (header-address mb
) mb-address
1044 (load-address mb
) load-address
1045 (load-end-address mb
) (+ load-address kernel-size
)
1046 (bss-end-address mb
) (+ load-address kernel-size
)
1047 (entry-address mb
) init-code-address
)
1048 (write-binary-record mb stream
))))))))))
1051 (defun dump-image-core (image stream
)
1052 (let ((*endian
* :little-endian
)
1053 (*record-all-funobjs
* nil
)
1057 (code-vectors-size 0)
1059 (simple-vectors-size 0)
1065 (code-vectors-numof 0)
1067 (simple-vectors-numof 0)
1068 (file-start-position (file-position stream
))
1070 (declare (special *record-all-funobjs
*))
1072 for p upfrom
(- (image-start-address image
) (image-ds-segment-base image
)) by
8
1073 until
(>= p
(image-cons-pointer image
))
1075 (let ((obj (image-memref image p nil
)))
1077 ((not obj
) 0) ; (+ 1mb (- 1mb)) vs. (+ 0 (- 1mb 1mb))
1078 (t (let ((new-pos (+ p file-start-position
1079 (- (image-ds-segment-base image
)
1080 (image-start-address image
)))))
1081 (let ((pad-delta (- new-pos
(file-position stream
))))
1082 (with-simple-restart (continue "Never mind.")
1083 (assert (<= 0 pad-delta
31) ()
1084 "pad-delta ~S for ~S (prev ~S), p: ~S, new-pos: ~S"
1085 pad-delta obj prev-obj p new-pos
))
1086 (incf pad-size pad-delta
))
1087 (set-file-position stream new-pos obj
))
1088 ;; (warn "Dump at address #x~X, filepos #x~X: ~A" p (file-position stream) obj)
1089 (let ((old-pos (file-position stream
))
1090 (write-size (write-binary-record obj stream
)))
1091 (incf total-size write-size
)
1093 (movitz-basic-vector
1094 (case (movitz-vector-element-type obj
)
1095 (:character
(incf strings-numof
)
1096 (incf strings-size write-size
))
1097 (:any-t
(incf simple-vectors-numof
)
1098 (incf simple-vectors-size write-size
))
1099 (:code
(incf code-vectors-numof
)
1100 (incf code-vectors-size write-size
))))
1101 (movitz-funobj (incf funobjs-numof
)
1102 (incf funobjs-size write-size
))
1103 (movitz-symbol (incf symbols-numof
)
1104 (incf symbols-size write-size
)
1105 (when (movitz-eql *movitz-nil
* (movitz-symbol-package obj
))
1106 (incf gensyms-numof
)))
1107 (movitz-cons (incf conses-numof
)
1108 (incf conses-size write-size
)))
1109 (assert (= write-size
(sizeof obj
) (- (file-position stream
) old-pos
)) ()
1110 "Inconsistent write-size(~D)/sizeof(~D)/file-position delta(~D) ~
1112 write-size
(sizeof obj
) (- (file-position stream
) old-pos
) obj
)
1116 (let ((total-size (file-position stream
))
1117 (sum (+ symbols-size conses-size funobjs-size strings-size
1118 simple-vectors-size code-vectors-size pad-size
)))
1119 (format t
"~&;;~%;; ~D symbols (~D gensyms) (~,1F KB ~~ ~,1F%), ~D conses (~,1F KB ~~ ~,1F%),
1120 ~D funobjs (~,1F KB ~~ ~,1F%), ~D strings (~,1F KB ~~ ~,1F%),
1121 ~D simple-vectors (~,1F KB ~~ ~,1F%), ~D code-vectors (~,1F KB ~~ ~,1F%).
1122 ~,1F KB (~,1F%) of padding.
1123 In sum this accounts for ~,1F%, or ~D bytes.~%;;~%"
1124 symbols-numof gensyms-numof
1125 (/ symbols-size
1024) (/ (* symbols-size
100) total-size
)
1126 conses-numof
(/ conses-size
1024) (/ (* conses-size
100) total-size
)
1127 funobjs-numof
(/ funobjs-size
1024) (/ (* funobjs-size
100) total-size
)
1128 strings-numof
(/ strings-size
1024) (/ (* strings-size
100) total-size
)
1129 simple-vectors-numof
(/ simple-vectors-size
1024) (/ (* simple-vectors-size
100) total-size
)
1130 code-vectors-numof
(/ code-vectors-size
1024) (/ (* code-vectors-size
100) total-size
)
1131 (/ pad-size
1024) (/ (* pad-size
100) total-size
)
1132 (/ (* sum
100) total-size
)
1135 (defun intern-movitz-symbol (name)
1136 (assert (not (eq (symbol-package name
) (find-package :common-lisp
)))
1138 "Trying to movitz-intern a symbol in the Common-Lisp package: ~S" name
)
1139 (or (gethash name
(image-oblist *image
*))
1140 (let ((symbol (make-movitz-symbol name
)))
1141 (when (get name
:setf-placeholder
)
1142 (setf (movitz-symbol-flags symbol
) '(:setf-placeholder
)
1143 (movitz-symbol-value symbol
) (movitz-read (get name
:setf-placeholder
))))
1144 (setf (gethash name
(image-oblist *image
*)) symbol
)
1145 (when (symbol-package name
)
1146 (let ((p (gethash (symbol-package name
) (image-read-map-hash *image
*))))
1148 (setf (movitz-symbol-package symbol
) p
))))
1149 (when (or (eq 'muerte.cl
:t name
)
1150 (keywordp (translate-program name
:muerte.cl
:cl
)))
1151 (pushnew :constant-variable
(movitz-symbol-flags symbol
))
1152 (setf (movitz-symbol-value symbol
)
1153 (movitz-read (translate-program (symbol-value (translate-program name
:muerte.cl
:cl
))
1157 (defun make-packages-hash (&optional
(*image
* *image
*))
1158 (let ((lisp-to-movitz-package (make-hash-table :test
#'eq
))
1159 (packages-hash (make-hash-table :test
#'equal
:size
23)))
1160 (labels ((movitz-package-name (name &optional symbol
)
1161 (declare (ignore symbol
))
1163 ((string= (string :keyword
) name
)
1165 ((and (< 7 (length name
))
1166 (string= (string 'muerte.
) name
:end2
7))
1168 (t #+ignore
(warn "Package ~S ~@[for symbol ~S ~]is not a Movitz package."
1171 (ensure-package (package-name lisp-package
&optional context
)
1172 (assert (not (member (package-name lisp-package
)
1173 #+allegro
'(excl common-lisp sys aclmop
)
1174 #-allegro
'(common-lisp)
1175 :test
#'string
=)) ()
1176 "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz."
1177 lisp-package context
)
1178 (setf (gethash lisp-package lisp-to-movitz-package
)
1179 (or (gethash package-name packages-hash nil
)
1180 (let* ((nicks (mapcar #'movitz-package-name
(package-nicknames lisp-package
)))
1181 (p (funcall 'muerte
::make-package-object
1183 :shadowing-symbols-list
(package-shadowing-symbols lisp-package
)
1184 :external-symbols
(make-hash-table :test
#'equal
)
1185 :internal-symbols
(make-hash-table :test
#'equal
)
1187 :use-list
(mapcar #'(lambda (up)
1188 (ensure-package (movitz-package-name (package-name up
))
1190 (package-use-list lisp-package
)))))
1191 (setf (gethash package-name packages-hash
) p
)
1192 (dolist (nick nicks
)
1193 (setf (gethash nick packages-hash
) p
))
1195 (let ((movitz-cl-package (ensure-package (symbol-name :common-lisp
)
1196 (find-package :muerte.common-lisp
))))
1197 (setf (gethash "NIL" (funcall 'muerte
:package-object-external-symbols movitz-cl-package
))
1199 (loop for symbol being the hash-key of
(image-oblist *image
*)
1200 as lisp-package
= (symbol-package symbol
)
1201 as package-name
= (and lisp-package
1202 (movitz-package-name (package-name lisp-package
) symbol
))
1204 do
(let* ((movitz-package (ensure-package package-name lisp-package symbol
)))
1205 (multiple-value-bind (symbol status
)
1206 (find-symbol (symbol-name symbol
) (symbol-package symbol
))
1209 (setf (gethash (symbol-name symbol
)
1210 (funcall 'muerte
:package-object-internal-symbols movitz-package
))
1213 ;; (warn "putting external ~S in ~S" symbol package-name)
1214 (setf (gethash (symbol-name symbol
)
1215 (funcall 'muerte
:package-object-external-symbols movitz-package
))
1218 (warn "inherited symbol: ~S" symbol
))))))
1219 ;;; (warn "PA: ~S" packages-hash)
1220 (let ((movitz-packages (movitz-read packages-hash
)))
1221 (maphash (lambda (lisp-package movitz-package
)
1222 (setf (gethash lisp-package
(image-read-map-hash *image
*))
1223 (movitz-read movitz-package
)))
1224 lisp-to-movitz-package
)
1225 (setf (slot-value (movitz-run-time-context-null-symbol (image-run-time-context *image
*))
1227 (movitz-read (ensure-package (string :common-lisp
) :muerte.common-lisp
)))
1228 (loop for symbol being the hash-key of
(image-oblist *image
*)
1229 as lisp-package
= (symbol-package symbol
)
1230 as package-name
= (and lisp-package
1231 (movitz-package-name (package-name lisp-package
) symbol
))
1232 ;;; do (when (string= symbol :method)
1233 ;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name))
1235 do
(let* ((movitz-package (ensure-package package-name lisp-package symbol
)))
1236 (setf (movitz-symbol-package (movitz-read symbol
))
1237 (movitz-read movitz-package
))))
1241 (defun run-time-context-find-slot (offset)
1242 "Return the name of the run-time-context slot located at offset."
1243 (dolist (slot-name (bt:binary-record-slot-names
'movitz-run-time-context
))
1244 (when (= offset
(bt:slot-offset
'movitz-run-time-context slot-name
))
1245 (return slot-name
))))
1247 (defun comment-instruction (instruction funobj pc
)
1248 "Return a list of strings that comments on INSTRUCTION."
1249 (loop for operand in
(ia-x86::instruction-operands instruction
)
1250 when
(and (typep operand
'ia-x86
::operand-indirect-register
)
1251 (eq 'ia-x86
::edi
(ia-x86::operand-register operand
))
1252 (not (ia-x86::operand-register2 operand
))
1253 (= 1 (ia-x86::operand-scale operand
))
1254 (run-time-context-find-slot (ia-x86::operand-offset operand
))
1255 (not (typep instruction
'ia-x86-instr
::lea
)))
1256 collect
(format nil
"<Global slot ~A>"
1257 (run-time-context-find-slot (ia-x86::operand-offset operand
)))
1258 when
(and (typep operand
'ia-x86
::operand-indirect-register
)
1259 (eq 'ia-x86
::edi
(ia-x86::operand-register operand
))
1260 (typep instruction
'ia-x86-instr
::lea
)
1261 (or (not (ia-x86::operand-register2 operand
))
1262 (eq 'ia-x86
::edi
(ia-x86::operand-register2 operand
))))
1263 collect
(let ((x (+ (* (ia-x86::operand-scale operand
)
1264 (image-nil-word *image
*))
1265 (ia-x86::operand-offset operand
)
1266 (ecase (ia-x86::operand-register2 operand
)
1267 (ia-x86::edi
(image-nil-word *image
*))
1269 (case (ldb (byte 3 0) x
)
1271 (format nil
"Immediate ~D (char ~S)"
1272 x
(code-char (ldb (byte 8 8) x
))))
1273 (#.
(mapcar 'tag
+fixnum-tags
+)
1274 (format nil
"Immediate ~D (fixnum ~D #x~X)"
1276 (truncate x
+movitz-fixnum-factor
+)
1277 (truncate x
+movitz-fixnum-factor
+)))
1278 (t (format nil
"Immediate ~D" x
))))
1280 (typep operand
'ia-x86
::operand-indirect-register
)
1281 (eq 'ia-x86
::esi
(ia-x86::operand-register operand
))
1282 (member (ia-x86::operand-register2 operand
) '(ia-x86::edi nil
))
1283 (= 1 (ia-x86::operand-scale operand
))
1284 #+ignore
(= (mod (slot-offset 'movitz-funobj
'constant0
) 4)
1285 (mod (ia-x86::operand-offset operand
) 4))
1286 (<= 12 (ia-x86::operand-offset operand
)))
1287 collect
(format nil
"~A"
1288 (nth (truncate (- (+ (ia-x86::operand-offset operand
)
1289 (if (eq 'ia-x86
::edi
(ia-x86::operand-register2 operand
))
1290 (image-nil-word *image
*)
1292 (slot-offset 'movitz-funobj
'constant0
))
1294 (movitz-funobj-const-list funobj
)))
1296 (typep operand
'ia-x86
::operand-indirect-register
)
1297 (eq 'ia-x86
::esi
(ia-x86::operand-register2 operand
))
1298 (eq 'ia-x86
::edi
(ia-x86::operand-register operand
))
1299 (<= 12 (ia-x86::operand-offset operand
)))
1300 collect
(format nil
"~A" (nth (truncate (- (+ (ia-x86::operand-offset operand
)
1301 (* (ia-x86::operand-scale operand
)
1302 (image-nil-word *image
*)))
1303 (slot-offset 'movitz-funobj
'constant0
))
1305 (movitz-funobj-const-list funobj
)))
1306 when
(typep operand
'ia-x86
::operand-rel-pointer
)
1307 collect
(let* ((x (+ pc
1308 (imagpart (ia-x86::instruction-original-datum instruction
))
1309 (length (ia-x86:instruction-prefixes instruction
))
1310 (ia-x86::operand-offset operand
)))
1311 (label (and funobj
(car (find x
(movitz-funobj-symtab funobj
) :key
#'cdr
)))))
1313 (format nil
"branch to ~S at ~D" label x
)
1314 (format nil
"branch to ~D" x
)))
1315 when
(and (typep operand
'ia-x86
::operand-immediate
)
1316 (<= 256 (ia-x86::operand-value operand
))
1317 (= (tag :character
) (mod (ia-x86::operand-value operand
) 256)))
1318 collect
(format nil
"#\\~C" (code-char (truncate (ia-x86::operand-value operand
) 256)))
1319 when
(and (typep operand
'ia-x86
::operand-immediate
)
1320 (zerop (mod (ia-x86::operand-value operand
)
1321 +movitz-fixnum-factor
+)))
1322 collect
(format nil
"#x~X" (truncate (ia-x86::operand-value operand
)
1323 +movitz-fixnum-factor
+))))
1325 (defun movitz-disassemble (name &rest args
&key
((:image
*image
*) *image
*) &allow-other-keys
)
1326 (let* ((funobj (or (movitz-env-named-function name
)
1327 (error "~S has no function definition." name
))))
1328 (declare (special *image
*))
1329 (apply #'movitz-disassemble-funobj funobj
:name name args
)))
1331 (defun movitz-assembly (name &optional
(*image
* *image
*))
1332 (let* ((funobj (movitz-env-named-function name
)))
1333 (declare (special *image
*))
1334 (format t
"~{~A~%~}" (movitz-funobj-symbolic-code funobj
))))
1336 (defun movitz-disassemble-toplevel (module)
1337 (let ((funobj (car (find module
(image-load-time-funobjs *image
*) :key
#'second
))))
1338 (assert funobj
(module)
1339 "No load funobj found for module ~S." module
)
1340 (movitz-disassemble-funobj funobj
:name module
)))
1342 (defun movitz-disassemble-method (name lambda-list
&optional qualifiers
)
1343 (let* ((gf (or (movitz-env-named-function name
)
1344 (error "No function named ~S." name
)))
1345 (specializing-lambda-list
1346 (subseq lambda-list
0
1347 (position-if (lambda (x)
1349 (char= #\
& (char (string x
) 0))))
1351 (specializers (mapcar #'muerte
::find-specializer
1356 specializing-lambda-list
)))
1357 (method (muerte::movitz-find-method gf qualifiers specializers
))
1358 (funobj (muerte::movitz-slot-value method
'muerte
::function
))
1360 (movitz-disassemble-funobj funobj
)))
1362 (defparameter *recursive-disassemble-remember-funobjs
* nil
)
1364 (defun movitz-disassemble-funobj (funobj &key
(name (movitz-funobj-name funobj
)) ((:image
*image
*) *image
*)
1366 (let* ((code-vector (movitz-funobj-code-vector funobj
))
1367 (code (map 'vector
#'identity
1368 (movitz-vector-symbolic-data code-vector
)))
1370 (entry-points (map 'list
#'identity
(subseq code
(movitz-vector-fill-pointer code-vector
)))))
1371 (format t
"~&;; Movitz Disassembly of ~A:~@[
1372 ;; ~D Constants: ~A~]
1373 ~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}"
1374 (movitz-print (or (movitz-funobj-name funobj
) name
))
1375 (length (movitz-funobj-const-list funobj
))
1376 (movitz-funobj-const-list funobj
)
1378 for pc
= 0 then code-position
1379 for instruction
= (ia-x86:decode-read-octet
1381 (when (< code-position
1382 (movitz-vector-fill-pointer code-vector
))
1384 (aref code code-position
)
1385 (incf code-position
)))))
1386 for cbyte
= (and instruction
1387 (ia-x86::instruction-original-datum instruction
))
1388 until
(null instruction
)
1389 when
(let ((x (find pc
(movitz-funobj-symtab funobj
) :key
#'cdr
)))
1390 (when x
(list pc
(list (format nil
" ~S" (car x
))) "" nil
)))
1392 when
(some (lambda (x)
1393 (and (plusp pc
) (= pc x
)))
1395 collect
(list pc nil
1396 (format nil
" => Entry-point for ~D arguments <="
1397 (1+ (position-if (lambda (x)
1402 (ia-x86::cbyte-to-octet-list cbyte
)
1404 (comment-instruction instruction funobj pc
)))))
1406 (let ((*recursive-disassemble-remember-funobjs
*
1407 (cons funobj
*recursive-disassemble-remember-funobjs
*)))
1408 (loop for x in
(movitz-funobj-const-list funobj
)
1409 do
(when (and (typep x
'(and movitz-funobj
(not movitz-funobj-standard-gf
)))
1410 (not (member x
*recursive-disassemble-remember-funobjs
*)))
1411 (push x
*recursive-disassemble-remember-funobjs
*)
1413 (movitz-disassemble-funobj x
)))))
1416 (defun movitz-disassemble-primitive (name &optional
(*image
* *image
*))
1417 (let* ((code-vector (cond
1418 ((slot-exists-p (image-run-time-context *image
*) name
)
1419 (slot-value (image-run-time-context *image
*) name
))
1420 (t (movitz-symbol-value (movitz-read name
)))))
1421 (code (map 'vector
#'identity
1422 (movitz-vector-symbolic-data code-vector
)))
1424 (format t
"~&;; Movitz disassembly of ~S:
1425 ~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}"
1428 for pc
= 0 then code-position
1429 for instruction
= (ia-x86:decode-read-octet
1431 (when (< code-position
(length code
))
1433 (aref code code-position
)
1434 (incf code-position
)))))
1435 until
(null instruction
)
1436 for cbyte
= (ia-x86::instruction-original-datum instruction
)
1438 (ia-x86::cbyte-to-octet-list cbyte
)
1440 (comment-instruction instruction nil pc
))))
1443 (defmethod image-read-intern-constant ((*image
* symbolic-image
) expr
)
1446 (or (gethash expr
(image-string-constants *image
*))
1447 (setf (gethash expr
(image-string-constants *image
*))
1448 (movitz-read expr
))))
1450 (or (gethash expr
(image-cons-constants *image
*))
1451 (setf (gethash expr
(image-cons-constants *image
*))
1452 (movitz-read expr
))))
1453 (t (movitz-read expr
))))
1457 (defmethod image-lisp-to-movitz-object ((image symbolic-image
) lisp-object
)
1458 (gethash lisp-object
(image-read-map-hash image
)))
1460 (defmethod (setf image-lisp-to-movitz-object
) (movitz-object (image symbolic-image
) lisp-object
)
1461 (setf (gethash movitz-object
(image-inverse-read-map-hash image
)) lisp-object
1462 (gethash lisp-object
(image-read-map-hash image
)) movitz-object
))
1464 (defmethod image-movitz-to-lisp-object ((image symbolic-image
) movitz-object
)
1465 (gethash movitz-object
(image-inverse-read-map-hash image
)))
1467 (defmacro with-movitz-read-context
(options &body body
)
1468 (declare (ignore options
))
1469 `(let ((*movitz-reader-clean-map
*
1470 (if (boundp '*movitz-reader-clean-map
*)
1471 (symbol-value '*movitz-reader-clean-map
*)
1472 (make-hash-table :test
#'eq
))))
1473 (declare (special *movitz-reader-clean-map
*))
1476 (defun movitz-read (expr &optional re-read
)
1477 "Map native lisp data to movitz-objects. Makes sure that when two EXPR are EQ, ~@
1478 the Movitz objects are also EQ, under the same image."
1479 (declare (optimize (debug 3) (speed 0)))
1480 (with-movitz-read-context ()
1481 (when (typep expr
'movitz-object
)
1482 (return-from movitz-read expr
))
1483 (or (and (not re-read
)
1484 (let ((old-object (image-lisp-to-movitz-object *image
* expr
)))
1485 (when (and old-object
(not (gethash old-object
*movitz-reader-clean-map
*)))
1486 (update-movitz-object old-object expr
)
1487 (setf (gethash old-object
*movitz-reader-clean-map
*) t
))
1489 (setf (image-lisp-to-movitz-object *image
* expr
)
1492 ((member t
) (movitz-read 'muerte.cl
:t
))
1493 ((eql unbound
) (make-instance 'movitz-unbound-value
))
1494 (symbol (intern-movitz-symbol expr
))
1495 (integer (make-movitz-integer expr
))
1496 (character (make-movitz-character expr
))
1497 (string (or (gethash expr
(image-string-constants *image
*))
1498 (setf (gethash expr
(image-string-constants *image
*))
1499 (make-movitz-string expr
))))
1500 (vector (make-movitz-vector (length expr
)
1501 :element-type
(array-element-type expr
)
1502 :initial-contents expr
))
1504 (or (let ((old-cons (gethash expr
(image-cons-constants *image
*))))
1506 (update-movitz-object old-cons expr
)
1508 (setf (gethash expr
(image-cons-constants *image
*))
1509 (if (eq '#0=#:error
(ignore-errors (when (not (list-length expr
)) '#0#)))
1510 (multiple-value-bind (unfolded-expr cdr-index
)
1511 (unfold-circular-list expr
)
1512 (let ((result (movitz-read unfolded-expr
)))
1513 (setf (movitz-last-cdr result
)
1514 (movitz-nthcdr cdr-index result
))
1516 (make-movitz-cons (movitz-read (car expr
))
1517 (movitz-read (cdr expr
)))))))
1519 (make-movitz-hash-table expr
))
1521 (make-instance 'movitz-ratio
1524 (let ((slot-descriptions (gethash (type-of expr
)
1525 (image-struct-slot-descriptions *image
*)
1527 (unless slot-descriptions
1528 (error "Don't know how to movitz-read struct: ~S" expr
))
1529 (let ((movitz-object (make-instance 'movitz-struct
1530 :class
(muerte::movitz-find-class
(type-of expr
))
1531 :length
(length slot-descriptions
))))
1532 (setf (image-lisp-to-movitz-object *image
* expr
) movitz-object
)
1533 (setf (slot-value movitz-object
'slot-values
)
1534 (mapcar #'(lambda (slot)
1535 (movitz-read (slot-value expr
(if (consp slot
) (car slot
) slot
))))
1539 (movitz-read (rationalize expr
))))))))
1543 (defun movitz-make-upload-form (object &optional
(quotep t
))
1546 ((or movitz-null null
) "()")
1548 (format nil
"(list~{ ~A~})"
1549 (mapcar #'movitz-make-upload-form object
)))
1551 (format nil
"(list~{ ~A~})"
1552 (mapcar #'movitz-make-upload-form
(movitz-print object
))))
1554 (format nil
"(internal:make-funobj :name ~A :constants ~A :code-vector ~A)"
1555 (movitz-make-upload-form (movitz-funobj-name object
))
1556 (movitz-make-upload-form (movitz-funobj-const-list object
))
1557 (movitz-print (movitz-funobj-code-vector object
))))
1559 (let ((package (movitz-symbol-package object
)))
1561 ((eq *movitz-nil
* package
)
1562 (if (member :setf-placeholder
(movitz-symbol-flags object
))
1563 (format nil
"(internal:setf-intern ~A)"
1564 (movitz-make-upload-form (movitz-symbol-value object
)))
1565 (format nil
"~:[~;'~]#:~A" quotep
(movitz-print object
))))
1566 (t (check-type package movitz-struct
)
1567 (assert (eq (movitz-struct-class package
)
1568 (muerte::movitz-find-class
'muerte
::package-object
)))
1569 (let ((package-name (intern (movitz-print (first (movitz-struct-slot-values package
))))))
1571 (keyword (format nil
":~A" (movitz-print object
)))
1572 (common-lisp (format nil
"~:[~;'~]~A" quotep
(movitz-print object
)))
1573 (t (format nil
"~:[~;'~]~A:~A" quotep package-name
(movitz-print object
)))))))))
1574 (movitz-basic-vector
1575 (case (movitz-vector-element-type object
)
1576 (:character
(format nil
"\"~A\"" (movitz-print object
)))
1577 (t (movitz-print object
))))
1578 (t (format nil
"~A" (movitz-print object
)))))
1581 (defun movitz-upload-function (name &optional
(destination :bochs
) (verbose nil
))
1582 (unless (stringp destination
)
1585 (:kayak
"fe80::240:f4ff:fe36:6f02%xl0")
1586 (:decpc
"fe80::240:5ff:fe18:66d7%xl0")
1587 (:bochs
"fe80::240:5ff:fe18:66d8%xl0"))))
1588 (let ((funobj (movitz-env-symbol-function name
))
1589 (*print-readably
* t
)
1590 (*print-pretty
* nil
)
1592 (*print-radix
* nil
))
1593 (let ((command (format nil
"(internal:install-function ~A (list~{ ~A~}) ~W)"
1594 (movitz-make-upload-form (movitz-read name
))
1595 (mapcar #'movitz-make-upload-form
(movitz-funobj-const-list funobj
))
1596 (movitz-print (movitz-funobj-code-vector funobj
)))))
1598 (pprint command
) (terpri) (force-output))
1600 #+allegro
(if destination
1601 (excl::run-shell-command
(format nil
"./udp6-send.py ~A 1 ~S" destination command
))
1607 (defun movitz-print (expr)
1608 "Find the host lisp object equivalent to the Movitz object expr."
1613 (cons (mapcar #'movitz-print expr
))
1614 ((or (satisfies movitz-null
) movitz-run-time-context
) nil
)
1615 (movitz-unbound-value 'unbound
)
1617 (movitz-fixnum-value expr
))
1618 (movitz-std-instance expr
)
1619 (movitz-struct expr
)
1621 (or (image-movitz-to-lisp-object *image
* expr
)
1622 (error "Unknown Movitz object: ~S" expr
)))))
1624 (defmethod make-toplevel-funobj ((*image
* symbolic-image
))
1625 (declare (special *image
*))
1626 (let ((toplevel-code (loop for
(funobj) in
(image-load-time-funobjs *image
*)
1627 collect
`(muerte::simple-funcall
,funobj
)))
1628 ;; We need toplevel-funobj's identity in the code below.
1629 (toplevel-funobj (make-instance 'movitz-funobj-pass1
)))
1630 (make-compiled-funobj 'muerte
::toplevel-function
()
1631 '((muerte::without-function-prelude
))
1633 (muerte::with-inline-assembly
(:returns
:nothing
)
1635 (:cld
) ; clear direction flag => "normal" register GC roots.
1637 (:movw
,(1- (* 8 5)) (:esp -
6))
1638 (:movl
,(+ (movitz-read-and-intern
1639 'muerte
::*initial-segment-descriptor-table
* 'word
)
1640 (image-ds-segment-base *image
*))
1642 (:movl
(:ecx
,(bt:slot-offset
'movitz-symbol
'value
))
1644 (:addl
,(+ (bt:slot-offset
'movitz-basic-vector
'data
)
1645 (image-ds-segment-base *image
*))
1647 (:movl
:ecx
(:esp -
4))
1651 (:pushl
,(ash (* 3 8) 0)) ; push segment selector
1652 (:call
(:pc
+ 0)) ; push EIP
1654 (:subl
'(:funcall
,(lambda (base dest
)
1655 (+ (image-cs-segment-base *image
*) (- dest
) base
))
1657 'jmp-base
'jmp-destination
)
1659 (:jmp-segment
(:esp
))
1662 (:movw
,(* 4 8) :cx
)
1667 (:movw
,(* 2 8) :cx
)
1668 (:movw
:cx
:gs
) ; physical context segment
1670 (:movl
,(image-nil-word *image
*) :edi
)
1671 (:globally
(:movl
(:edi
(:edi-offset stack-top
)) :esp
))
1679 (:movl
'(:funcall
,(lambda () (movitz-intern toplevel-funobj
)))
1683 (:cmpl
#x2badb002
:eax
)
1684 (:jne
'no-multiboot
)
1685 (:movl
,(movitz-read-and-intern 'muerte
::*multiboot-data
* 'word
)
1687 ;; (:compile-form (:result-mode :eax) 'muerte::*multiboot-data*)
1688 ;; (:shll ,+movitz-fixnum-shift+ :ebx)
1689 (:movl
:ebx
(:eax
,(bt:slot-offset
'movitz-symbol
'value
)))
1691 ;; Check that the stack works..
1692 ;;; (:pushl #xabbabeef)
1694 ;;; (:cmpl #xabbabeef :eax)
1695 ;;; (:jne '(:sub-program (stack-doesnt-work)
1696 ;;; (:movl :ebp :eax)
1697 ;;; (:movl #xb8020 :ebx)
1698 ;;; ,@(mkasm-write-word-eax-ebx)
1699 ;;; (:movl (:edi -1) :eax)
1700 ;;; (:movl #xb8040 :ebx)
1701 ;;; ,@(mkasm-write-word-eax-ebx)
1702 ;;; (:jmp (:pc+ -2)))))
1706 nil t
:funobj toplevel-funobj
)))
1708 (defun mkasm-write-word-eax-ebx ()
1709 (let ((loop-label (make-symbol "write-word-loop"))
1710 (l1 (make-symbol "write-word-l1"))
1711 (l2 (make-symbol "write-word-l2"))
1712 (l3 (make-symbol "write-word-l3"))
1713 (l4 (make-symbol "write-word-l4")))
1714 `(;; (:compile-two-forms (:eax :ebx) ,word ,dest)
1717 ;; (:shrl #.los0::+movitz-fixnum-shift+ :ebx)
1720 ((:gs-override
) :movl
#x07000700
(:ebx
0))
1721 ((:gs-override
) :movl
#x07000700
(:ebx
4))
1722 ((:gs-override
) :movl
#x07000700
(:ebx
8))
1723 ((:gs-override
) :movl
#x07000700
(:ebx
12))
1726 (:andl
#x0f0f0f0f
:eax
)
1727 (:addl
#x30303030
:eax
)
1729 (:cmpb
#x39
:al
) (:jle
',l1
) (:addb
7 :al
)
1730 ,l1
((:gs-override
) :movb
:al
(14 :ebx
)) ; 8
1731 (:cmpb
#x39
:ah
) (:jle
',l2
) (:addb
7 :ah
)
1732 ,l2
((:gs-override
) :movb
:ah
(10 :ebx
)) ; 6
1736 (:cmpb
#x39
:al
) (:jle
',l3
) (:addb
7 :al
)
1737 ,l3
((:gs-override
) :movb
:al
(6 :ebx
)) ; 4
1738 (:cmpb
#x39
:ah
) (:jle
',l4
) (:addb
7 :ah
)
1739 ,l4
((:gs-override
) :movb
:ah
(2 :ebx
)) ; 2
1745 (:jnz
',loop-label
))))
