source: trunk/split-lfun.lisp @ 3

Revision 3, 13.7 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; split-lfun.lisp
6;; Code to split an lfun into pieces that WOOD knows how to save
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17;;
18
19;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;
21;; Modification History
22;;
23;; -------------- 0.96
24;; 05/28/96 bill  %patch-lfun-immediates uses uvsize instead of length on the lfun
25;;                split-lfun, join-lfun, & join-lfun-with-dummy-immediates special
26;;                case closures and are a little more efficient.
27;; -------------- 0.95
28;; 03/20/96 bill  ppc-target code
29;; -------------- 0.93
30;; 06/30/95 bill  split-lfun now works in MCL 3.0.
31;; -------------- 0.9
32;; 10/13/94 gz    optional preserve-lfun-info-p arg to split-lfun
33;; 10/11/94 bill  split-lfun no longer attempts to skip immediate map when
34;;                there is none. Thanx to Chris DiGiano for finding this one.
35;; -------------- 0.8
36;; 11/09/93 bill  %patch-lfun-immediates
37;; -------------- 0.6
38;; -------------- 0.5
39;; 03/13/92 bill  New file
40;;
41
42(in-package :ccl)
43
44(export '(split-lfun join-lfun))
45
46(defvar *fasl-min-version* fasl-version)
47(defvar *fasl-max-version* fasl-version)
48
49#-ppc-target
50(progn
51
52(eval-when (:compile-toplevel :execute)
53  (require :lispequ)
54  (require :lapmacros))
55
56; 2 bytes of attributes + 4 bytes of bits in words:
57(defconstant $lfun-overhead-words 3)
58
59(defconstant $lfun-linkmap-offset
60  #+ccl-3 3                             ; bits at end in MCL 3.0
61  #-ccl-3 1)                            ; bits at beginning in MCL 2.0
62
63; Returns a list of length 6: (imms icode linkmap bits attrib fasl-version)
64; If you APPLY JOIN-LFUN to this list, you will get a copy of the lfun.
65; Note that the icode & linkmap vectors are of type (array (unsigned-byte 16)).
66; ccl::%make-lfun requires that they be of exactly that type.
67; Code largely copied from fasl-dump-lfun-vector.
68; Tested in 2.0f3c2
69
70(defun split-lfun (lfun preserve-lfun-info-p)
71  (let* ((lfunv (%lfun-vector lfun))
72         (lfunv-len (uvsize lfunv))
73         icode
74         (imm-count (%count-immrefs lfunv))
75         (imms nil)
76         (linkmap (make-array (ash imm-count 1)
77                              :element-type '(signed-byte 16)
78                              :initial-element $lm_longimm))
79         (bits (lfun-bits lfun))
80         (attrib (lfun-attributes lfun))
81         (info-index (and (not preserve-lfun-info-p)
82                          (%ilogbitp $lfatr-symmap-bit attrib)
83                          (%i- imm-count (if (%ilogbitp $lfatr-noname-bit attrib) 1 2)))))
84    (declare (fixnum lfunv-len imm-count))
85    (if (logbitp $lfatr-slfunv-bit attrib)
86      ; swappable lfun-vectors have an extra longword at the end
87      (decf lfunv-len 2))
88    ; Skip the immediate map at the end of the lfun vector.
89    (when (logbitp $lfatr-immmap-bit attrib)
90      (do ((i (- lfunv-len $lfun-linkmap-offset) (1- i)))
91          ((< i 0) (error "Immediate map took entire lfun"))
92        (decf lfunv-len)
93        (let ((word (uvref lfunv i)))
94          (declare (fixnum word))
95          (if (or (eql 0 (logand #xff word))
96                  (eql 0 (logand #xff00 word)))
97            (return)))))
98    (decf lfunv-len  $lfun-overhead-words)     ; skip the header.
99    (setq icode (make-array lfunv-len :element-type '(signed-byte 16)))
100    (do ((i 0 (1+ i))
101         (j (/ (- $lfv_lfun $v_data) 2) (1+ j))
102         (immno -1)
103         (u-imm-count 0))
104        ((>= i lfunv-len) (setq imm-count u-imm-count))
105      (declare (fixnum i j))
106      (if (%immref-p i lfunv)
107        (multiple-value-bind (imm offset)
108                             (%nth-immediate lfunv (incf immno 1))
109          (when (eq immno info-index) (setq imm nil offset nil))
110          (let ((first-imm (memq imm imms))
111                (v-immno u-imm-count))
112            (if first-imm
113              (setq v-immno (length (cdr first-imm)))
114              (progn
115                (push imm imms)
116                (incf u-imm-count)))
117            (setf (aref icode i) (or offset 0))
118            (setf (aref icode (1+ i)) v-immno)
119            (setf (aref linkmap (+ immno immno))
120                  (%immediate-offset lfunv immno))
121            (incf i)
122            (incf j)))
123        (setf (aref icode i) (uvref lfunv j))))
124    (list (make-array imm-count :initial-contents (nreverse imms))
125          icode linkmap bits attrib fasl-version)))
126
127; imms is a sequence of Lisp values, preferably of type (array t)
128; icode is an array of opcodes, preferably of type (array (unsigned-byte 16)).
129; linkmap is alternating (byte) offsets in icode and
130; $lm_longimm's,  preferably of type (array (unsigned-byte 16)).
131; bits is the LFUN-BITS of the function.
132; attrib is its LFUN-ATTRIBUTES.
133
134; At each linkmap referenced offset in icode, there are two (16-bit)
135; words: a constant to add to the immediate (offsets a symbol to its
136; value cell or function entry) and the index in IMMS for the immediate
137; that goes there. This function just calls %MAKE-LFUN after coercing the
138; sequences to the correct type and doing a little error checking.
139
140; The list returned by split-lfun is taylor made to call join-lfun.
141; (apply 'join-lfun (split-lfun #'split-lfun)) will get you a copy
142; of #'split-lfun.
143
144(defun join-lfun (imms icode linkmap bits attrib &optional (fver fasl-version))
145  (unless (<= *fasl-min-version* fver *fasl-max-version*)
146    (cerror "they're compatible. Stop bothering me with error messages."
147            "LFUN saved with FASL version #x~x, ~s is now #x~x."
148            fver 'fasl-version fasl-version)
149    (setq *fasl-min-version* (min fver *fasl-min-version*)
150          *fasl-max-version* (max fver *fasl-max-version*)))
151  (symbol-macrolet ((array-type '(array (signed-byte 16))))
152    (let* ((imms (if (typep imms '(array t))
153                   imms
154                   (coerce imms '(array t))))
155           (imms-length (length imms))
156           (icode (if (typep icode array-type)
157                    icode
158                    (coerce icode array-type)))
159           (icode-bytes (* 2 (length icode)))
160           (linkmap (if (typep linkmap array-type)
161                      linkmap
162                      (coerce icode array-type)))
163           (linkmap-length (length linkmap))
164           (bits (require-type bits 'fixnum))
165           (attrib (require-type attrib 'fixnum)))
166      (unless (evenp linkmap-length)
167        (error "~s has an odd number of elements." linkmap))
168      (do ((i 0 (+ i 2)))
169          ((>= i linkmap-length))
170        (declare (fixnum i))
171        (let ((offset (aref linkmap i))
172              (type (aref linkmap (the fixnum (1+ i)))))
173          (declare (fixnum offset))
174          (unless (eql type $lm_longimm)
175            (error "Type code ~s is not ~s" type $lm_longimm))
176          (unless (and (evenp offset) (< -1 offset icode-bytes))
177            (error "Offset ~s odd or out of range." offset))
178          (setq offset (ash offset -1))
179          (let ((sym-adjust (aref icode offset))
180                (imms-index (aref icode (the fixnum (1+ offset)))))
181            (declare (fixnum sym-adjust imms-index))
182            (unless (and (< -1 imms-index imms-length)
183                         (or (eql sym-adjust 0)
184                             (and (symbolp (aref imms imms-index))
185                                  (or (eql sym-adjust 8)
186                                      (eql sym-adjust 16)))))
187              (error "Malformed immediate specifier at index ~s in ~s"
188                     offset icode)))))
189      (%make-lfun imms icode linkmap bits attrib))))
190
191; WOOD needs to create an LFUN before filling in its immediates.
192; This function creates an LFUN with dummy immediates and three values
193; suitable for passing to %patch-lfun-immediates below (after filling in
194; the immediates):
195;   1) The lfun
196;   2) The dummy immediates vector. FIll this in with the real immediates
197;   3) A vector containing the index in the immediates vector for each immediate in the lfun
198(defun join-lfun-with-dummy-immediates (icode linkmap bits attrib &optional (fver fasl-version))
199  (let* ((imm-count (ash (length linkmap) -1))
200         (indices (make-array imm-count))
201         (max-index -1))
202    (declare (fixnum imm-count))
203    (dotimes (i imm-count)
204      (let ((index (aref icode (1+ (ash (aref linkmap (+ i i)) -1)))))
205        (when (> index max-index) (setq max-index index))
206        (setf (aref indices i) index)))
207    (let ((imms (make-array (1+ max-index) :initial-element '*%dummy-imm%*)))
208      (values (join-lfun imms icode linkmap bits attrib fver)
209              imms
210              indices))))
211
212; Patch lfun by changing its immediates to new-immediates.
213; indices contains an index in new-immediates for each immediate in lfun.
214(defun %patch-lfun-immediates (lfun new-immediates indices)
215  (let* ((lfv (%lfun-vector lfun))
216         (count (%count-immrefs lfv)))
217    (declare (fixnum count))
218    (setq new-immediates (require-type new-immediates 'simple-vector)
219          indices (require-type indices 'simple-vector))
220    (unless (eql count (length indices))
221      (error "indices not a vector of the correct length"))
222    (dotimes (i count)
223      (let ((index (%svref indices i)))
224        (multiple-value-bind (old-imm imm-offset) (%nth-immediate lfv i)
225          (declare (ignore old-imm))
226          (let ((lfun-offset (%immediate-offset lfv i)))
227            (lap-inline (imm-offset lfun-offset (svref new-immediates index))
228              (:variable lfun)
229              (move.l (varg lfun) atemp0)
230              (getint arg_x)              ; imm-offset
231              (getint arg_y)              ; lfun-offset
232              (add.l arg_x arg_z)
233              (move.l arg_z (atemp0 arg_y)))))))
234    (lap-inline () (jsr_subprim $sp-clrcache)))
235  lfun)
236
237)  ; end of #-ppc-target progn
238
239#+ppc-target
240(progn
241
242(defun split-lfun (lfun &optional preserve-lfun-info-p)
243  (declare (ignore preserve-lfun-info-p))
244  (declare (special %closure-code%))
245  (unless (functionp lfun)
246    (setq lfun (require-type lfun 'function)))
247  (let* ((code-vector (uvref lfun 0))
248         (code-words (unless (eq code-vector %closure-code%) (normalize-code-vector code-vector)))
249         (size (1- (uvsize lfun)))
250         (imm-vector (make-array size)))
251    (declare (fixnum code-vector-length size))
252    (dotimes (i size)
253      (setf (%svref imm-vector i) (uvref lfun (1+ i))))
254    (list imm-vector code-words size fasl-version)))
255
256(defun check-fasl-version (fver)
257  (unless (<= *fasl-min-version* fver *fasl-max-version*)
258    (cerror "they're compatible. Stop bothering me with error messages."
259            "LFUN saved with PFSL version #x~x, ~s is now #x~x."
260            fver 'fasl-version fasl-version)
261    (setq *fasl-min-version* (min fver *fasl-min-version*)
262          *fasl-max-version* (max fver *fasl-max-version*))))
263
264(defun join-lfun (imm-vector code-words imms-count &optional (fver fasl-version))
265  (declare (special %closure-code%))
266  (check-fasl-version fver)
267  (unless (eql imms-count (the fixnum (length imm-vector)))
268    (error "imms-count mismatch"))
269  (let* ((code-vector-length (length code-words))
270         (closure-p (null code-words))
271         (code-vector (if closure-p
272                        %closure-code%
273                        (make-uvector code-vector-length ppc::subtag-code-vector)))
274         (lfun (make-uvector (1+ imms-count) ppc::subtag-function)))
275    (setf (uvref lfun 0) code-vector)
276    (dotimes (i imms-count)
277      (setf (uvref lfun (1+ i)) (aref imm-vector i)))
278    (unless closure-p
279      (let ((typecode (extract-typecode code-words)))
280        (if (or (eql typecode ppc::subtag-u32-vector)
281                (eql typecode ppc::subtag-s32-vector))
282          (%copy-ivector-to-ivector code-words 0 code-vector 0 (ash code-vector-length 2))
283          (dotimes (i code-vector-length)
284            (setf (uvref code-vector i) (aref code-words i))))))
285    (without-interrupts (%make-code-executable code-vector))
286    lfun))
287
288(defun join-lfun-with-dummy-immediates (code-words imms-count &optional (fver fasl-version))
289  (declare (special %closure-code%))
290  (check-fasl-version fver)
291  (let* ((code-vector-length (length code-words))
292         (imms (make-array imms-count))
293         (closure-p (null code-words))
294         (code-vector (if closure-p
295                        %closure-code%
296                        (make-uvector code-vector-length ppc::subtag-code-vector)))
297         (lfun (make-uvector (1+ imms-count) ppc::subtag-function)))
298    (setf (uvref lfun 0) code-vector)
299    (unless closure-p
300      (let ((typecode (extract-typecode code-words)))
301        (if (or (eql typecode ppc::subtag-u32-vector)
302                (eql typecode ppc::subtag-s32-vector))
303          (%copy-ivector-to-ivector code-words 0 code-vector 0 (ash code-vector-length 2))
304          (dotimes (i code-vector-length)
305            (setf (uvref code-vector i) (aref code-words i))))))
306    (without-interrupts (%make-code-executable code-vector))
307    (values lfun imms)))
308
309(defun %patch-lfun-immediates (lfun new-immediates &optional ignore)
310  (declare (ignore ignore))
311  (let ((imms-count (length new-immediates)))
312    (unless (eql (uvsize lfun) (1+ imms-count))
313      (error "Wrong length immediates vector"))
314    (dotimes (i imms-count)
315      (setf (uvref lfun (1+ i)) (aref new-immediates i)))
316    lfun))
317
318)  ; end of #+ppc-target progn
319
320
321;;;    1   3/10/94  bill         1.8d247
322;;;    2  10/13/94  gz           1.9d074
323;;;    3  11/01/94  Derek        1.9d085 Bill's Saving Library Task
324;;;    2   3/23/95  bill         1.11d010
325;;;    3   8/01/95  bill         1.11d065
Note: See TracBrowser for help on using the repository browser.