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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 2002-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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(defun target-image-abi-version ()
100  (let* ((pkg (pkg-arg "TARGET"))
101         (sym (find-symbol "*IMAGE-ABI-VERSION*" pkg)))
102    (or (and sym (boundp sym) (symbol-value sym))
103        (error "*IMAGE-ABI-VERSION* not defined in ~s" pkg))))
104         
105
106(defun write-image-file (pathname image-base spaces )
107  (let* ((abi-version (target-image-abi-version)))
108    (target-setup-image-header-sizes)
109    (with-open-file (f pathname
110                       :direction :output
111                       :if-does-not-exist :create
112                       :if-exists :supersede
113                       :element-type '(unsigned-byte 8))
114      (let* ((nsections (length spaces))
115             (header-pos (- 4096 (+ *image-header-size*
116                                    (* nsections *image-section-size*)))))
117        (file-position f header-pos)
118        (image-write-fullword image-sig0 f)
119        (image-write-fullword image-sig1 f)
120        (image-write-fullword image-sig2 f)
121        (image-write-fullword image-sig3 f)
122        (image-write-fullword (get-universal-time) f)
123        (image-write-fullword (target-word-size-case
124                               (32 *xload-image-base-address*)
125                               (64 0)) f)
126        (image-write-fullword (target-word-size-case
127                               (32 image-base)
128                               (64 0)) f)
129        (image-write-fullword nsections f)
130        (image-write-fullword abi-version f)
131        (target-word-size-case
132         (32
133          (dotimes (i 2) (image-write-fullword 0 f))
134       
135          (image-write-fullword (backend-target-platform *target-backend*) f)
136          (dotimes (i 4) (image-write-fullword 0 f)))
137         (64
138          (image-write-fullword 0 f)
139          (image-write-fullword 0 f)
140          (image-write-fullword (backend-target-platform *target-backend*) f)
141          (image-write-doubleword *xload-image-base-address* f)
142          (image-write-doubleword image-base f)))
143        (dolist (sect spaces)
144          (image-write-natural (ash (xload-space-code sect)
145                                    *xload-target-fixnumshift*)
146                               f)
147          (image-write-natural 0 f)
148          (let* ((size (xload-space-lowptr sect)))
149            (image-write-natural size f)
150            (image-write-natural 0 f))) ; static dnodes.
151        (dolist (sect spaces)
152          (image-align-output-position f)
153          (stream-write-ivector f
154                                (xload-space-data sect)
155                                0
156                                (xload-space-lowptr sect)))
157        ;; Write an openmcl_image_file_trailer.
158        (image-write-fullword image-sig0 f)
159        (image-write-fullword image-sig1 f)
160        (image-write-fullword image-sig2 f)
161        (let* ((pos (+ 4 (file-position f))))
162          (image-write-fullword (- header-pos pos) f))
163        nil))))
164
165     
166     
167   
Note: See TracBrowser for help on using the repository browser.