source: trunk/source/xdump/heap-image.lisp @ 14867

Last change on this file since 14867 was 14867, checked in by rme, 8 years ago

Bump max image, fasl versions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2002-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18(defconstant image-sig0 (dpb (char-code #\O)
19                             (byte 8 24)
20                             (dpb (char-code #\p)
21                                  (byte 8 16)
22                                  (dpb (char-code #\e)
23                                       (byte 8 8)
24                                       (char-code #\n)))))
25(defconstant image-sig1 (dpb (char-code #\M)
26                             (byte 8 24)
27                             (dpb (char-code #\C)
28                                  (byte 8 16)
29                                  (dpb (char-code #\L)
30                                       (byte 8 8)
31                                       (char-code #\I)))))
32(defconstant image-sig2 (dpb (char-code #\m)
33                             (byte 8 24)
34                             (dpb (char-code #\a)
35                                  (byte 8 16)
36                                  (dpb (char-code #\g)
37                                       (byte 8 8)
38                                       (char-code #\e)))))
39(defconstant image-sig3 (dpb (char-code #\F)
40                             (byte 8 24)
41                             (dpb (char-code #\i)
42                                  (byte 8 16)
43                                  (dpb (char-code #\l)
44                                       (byte 8 8)
45                                       (char-code #\e)))))
46
47#|
48(def-foreign-type
49    openmcl-image-section-header
50    (:struct nil
51             (:code :unsigned-long)
52             (:area (:* t))
53             (:memory-size :unsigned-long)
54             (:static-dnodes :unsigned-long)))
55|#
56
57(defparameter *image-section-size* ())
58
59
60
61(defparameter *image-header-size* nil)
62
63(defun target-setup-image-header-sizes ()
64  (setq *image-header-size* (* 4 16))
65  (setq *image-section-size* (* 4 (target-word-size-case
66                                   (32 4)
67                                   (64 8)))))
68
69(defun image-write-fullword (w f &optional force-big-endian)
70  (cond ((or force-big-endian *xload-target-big-endian*)
71         (write-byte (ldb (byte 8 24) w) f)
72         (write-byte (ldb (byte 8 16) w) f)
73         (write-byte (ldb (byte 8 8) w) f)
74         (write-byte (ldb (byte 8 0) w) f))
75        (t
76         (write-byte (ldb (byte 8 0) w) f)
77         (write-byte (ldb (byte 8 8) w) f)
78         (write-byte (ldb (byte 8 16) w) f)
79         (write-byte (ldb (byte 8 24) w) f))))
80
81(defun image-write-doubleword (dw f)
82  (cond (*xload-target-big-endian*
83         (image-write-fullword (ldb (byte 32 32) dw) f)
84         (image-write-fullword (ldb (byte 32 0) dw) f))
85        (t
86         (image-write-fullword (ldb (byte 32 0) dw) f)
87         (image-write-fullword (ldb (byte 32 32) dw) f))))
88
89(defun image-write-natural (n f)
90  (target-word-size-case
91   (32 (image-write-fullword n f))
92   (64 (image-write-doubleword n f))))
93
94(defun image-align-output-position (f)
95  (file-position f (logand (lognot 4095)
96                           (+ 4095 (file-position f)))))
97
98
99(defparameter *image-abi-version* 1037)
100
101(defun write-image-file (pathname image-base spaces &optional (abi-version *image-abi-version*))
102  (target-setup-image-header-sizes)
103  (with-open-file (f pathname
104                     :direction :output
105                     :if-does-not-exist :create
106                     :if-exists :supersede
107                     :element-type '(unsigned-byte 8))
108    (let* ((nsections (length spaces))
109           (header-pos (- 4096 (+ *image-header-size*
110                                  (* nsections *image-section-size*)))))
111      (file-position f header-pos)
112      (image-write-fullword image-sig0 f)
113      (image-write-fullword image-sig1 f)
114      (image-write-fullword image-sig2 f)
115      (image-write-fullword image-sig3 f)
116      (image-write-fullword (get-universal-time) f)
117      (image-write-fullword (target-word-size-case
118                             (32 *xload-image-base-address*)
119                             (64 0)) f)
120      (image-write-fullword (target-word-size-case
121                             (32 image-base)
122                             (64 0)) f)
123      (image-write-fullword nsections f)
124      (image-write-fullword abi-version f)
125      (target-word-size-case
126       (32
127        (dotimes (i 2) (image-write-fullword 0 f))
128       
129        (image-write-fullword (backend-target-platform *target-backend*) f)
130        (dotimes (i 4) (image-write-fullword 0 f)))
131       (64
132        (image-write-fullword 0 f)
133        (image-write-fullword 0 f)
134        (image-write-fullword (backend-target-platform *target-backend*) f)
135        (image-write-doubleword *xload-image-base-address* f)
136        (image-write-doubleword image-base f)))
137      (dolist (sect spaces)
138        (image-write-natural (ash (xload-space-code sect)
139                                  *xload-target-fixnumshift*)
140                             f)
141        (image-write-natural 0 f)
142        (let* ((size (xload-space-lowptr sect)))
143          (image-write-natural size f)
144          (image-write-natural 0 f)))   ; static dnodes.
145      (dolist (sect spaces)
146        (image-align-output-position f)
147        (stream-write-ivector f
148                              (xload-space-data sect)
149                              0
150                              (xload-space-lowptr sect)))
151      ;; Write an openmcl_image_file_trailer.
152      (image-write-fullword image-sig0 f)
153      (image-write-fullword image-sig1 f)
154      (image-write-fullword image-sig2 f)
155      (let* ((pos (+ 4 (file-position f))))
156        (image-write-fullword (- header-pos pos) f))
157      nil)))
158
159     
160     
161   
Note: See TracBrowser for help on using the repository browser.