1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PK:FASLIN.SL
4% Title:        Loading of binary format files.
5% Author:       E. Benson
6% Created:      ???
7% Status:       Experimental
8% Mode:         Lisp
9% Package:      Kernel
10% Compiletime:  PL:FASL-DECLS.B
11% Runtime:
12%
13% (c) Copyright 1983, Hewlett-Packard Company, all rights reserved.
14%
15%
16%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
17%
18% Revisions:
19%
20% 1-Nov-90  (Winfried Neun)
21%  Initial version for IBM RS 6000
22% 14-Jun-88 (Tsuyoshi Yamamoto)
23%  Added new relocation types (relocate-movex,relocate-call) and long word
24%  alignment for halfword access.
25% 10-Jan-84 (Brian Beach)
26%  Commented-in checking of fasl-magic-number.
27% 13-Nov-84 14:13:11 (Brian Beach)
28%  Moved FASLIN-INTERN to INTERN.SL.
29% 10-May-84 14:35:05 (Brian Beach)
30%  Changed fasl-magic-number to faslin-magic (which is defined now in SYS-CONSTS.)
31% 01-Dec-83 14:44:33 (Brian Beach)
32%   Translated from Rlisp to Lisp.
33%
34%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
35
36(compiletime (load fasl-decls)
37(ds reloc-inf-tag (x) (field x 8 2))
38(ds reloc-inf-inf (x) (field x 42 22))
39)
40
41
42(on fast-integers)
43
44(fluid '(code-base-hack
45	 symfnc
46	 symval
47	 tokenbuffer
48	 argumentblock))
49
50(compiletime (flag '(relocate-movex relocate-inf relocate-word read-id-table/de
51		     do-relocation relocate-right-half compute-relocation
52		     local-to-global-id) 'internalfunction))
53
54
55(de faslin (file)
56  (prog (fid                  % file pointer
57	 local-id-count       % number of ids in the file
58	 local-id-table       % table for mapping local ID numbers to global ID numbers.
59	 code-size            % number of words of code
60	 code-base            % location of the start of the code
61	 init-function-address% Offset into the code of the init function
62	 bit-table-size       % number of words in the bit table
63	 bit-table            % the bit table
64	 Btop
65	 )
66
67    % Open the file
68    (setf fid (binaryopenread file))
69
70    % Check that the first word is the correct magic number.
71    (let ((first-word (binaryread fid)))
72      (unless (weq first-word faslin-magic)
73	(binaryclose fid)
74	(faslin-bad-file file)
75	(return nil)
76	))
77
78    % Read in the ID table.
79    (setf local-id-table (read-id-table fid))
80
81    % Read the code.
82    (setf code-size (binaryread fid)) % Size of code segment in words
83    (setf code-base (gtbps code-size)) % Allocate space in BPS
84    (setq Btop (GtBPS 0))              % pointer to top of alloc. BPS
85    (setf init-function-address (wplus2 code-base (binaryread fid)))
86    (binaryreadblock fid (loc (wgetv code-base 0)) code-size)
87
88    % Read the bit table
89    (setf bit-table-size (binaryread fid))
90    (setq bit-table (gtwrds bit-table-size))
91    (setq bit-table (mkwrds bit-table))
92    (binaryreadblock fid (loc (words-fetch bit-table 0)) bit-table-size)
93
94    % Close the file
95    (binaryclose fid)
96
97    % Twiddle the bits.
98    (do-relocation code-base code-size bit-table local-id-table)
99
100    % Call the init code
101    (let ((temp code-base-hack))  % avoid use of fluid binding
102      (setf code-base-hack code-base)
103      (flushcache code-base (wdifference btop code-base) 0)
104      (external_system (strbase (strinf "sync")))
105      (addressapply0 init-function-address)
106      (setf code-base-hack temp)
107      (DelBPS (wplus2 init-function-address 4) Btop)
108      )
109    ))
110
111
112(define-constant reloc-movex 1)
113(define-constant reloc-call  2)
114(define-constant reloc-xidloc 3)
115
116(compiletime (put 'halfword_getmem 'opencode
117                '((lwz (reg 1) (displacement (reg 1) 0)) ))
118             (put 'halfword_putmem 'opencode
119                '((stw (reg 2) (displacement (reg 1) 0)))))
120
121(de do-relocation (code-base code-size bit-table id-table)
122  % CODE-AU-SIZE is the size of the code measured in addressing
123  % units, rather than words.
124
125  (let ((code-au-size code-size )) %addressingunitsperitem)))
126    (for (from i 0 (wshift (wdifference code-au-size 1) 3) 4)
127     (do
128      (let ((bit-table-entry  (bittable (loc (words-fetch bit-table 0)) i))
129	    (code-location    (wplus2 code-base i  ))	memo )
130	(case bit-table-entry
131	 ((reloc-word)
132	  (case (bittable (loc (words-fetch bit-table 0))
133					 (wplus2 i 1))
134	 	((0) (relocate-word code-location code-base id-table))
135		((reloc-movex)
136		    (relocate-movex code-location code-base id-table))
137		((reloc-call)
138		    (progn (setq memo (halfword_getmem code-location))
139		            (setq memo
140		                (wplus2 memo (wshift (wshift code-base 6) -6)))
141		                        %clear out first bits (see J instr!)
142		                (halfword_putmem code-location memo)))
143		((reloc-xidloc)
144		    (progn (setq memo (wand (halfword_getmem code-location)
145					16#ffff))
146		           (when (local-id-number? memo)
147		               (setq memo (local-to-global-id memo id-table)))
148		           (halfword_putmem code-location
149		             (wor (wand (halfword_getmem code-location)
150					(wnot 16#ffff))
151		             (wand (wtimes2 8  (wplus2 memo -4000)) 16#ffff)))
152		      ))))
153		     %
154	((reloc-inf) (relocate-inf code-location code-base id-table))
155	((reloc-right-half)
156	       (relocate-right-half code-location code-base id-table))
157))))))
158
159
160(de relocate-word (code-location code-base id-table)
161  (let ((reloc-tag (reloc-word-tag (halfword_getmem code-location)))
162	(reloc-inf (reloc-word-inf (halfword_getmem code-location))))
163    (cond ((posintp (halfword_getmem code-location))
164			% a naked pointer from movex
165	     (halfword_putmem  code-location
166		 (wplus2 code-base (halfword_getmem code-location)) ))
167	  (t (halfword_putmem code-location % an item
168		(compute-relocation reloc-tag reloc-inf code-base id-table))))
169      ))
170
171(de relocate-inf  (code-location code-base id-table)
172  (let ((reloc-tag (reloc-inf-tag (getmem code-location)))
173	(reloc-inf (reloc-inf-inf (getmem code-location))))
174    (putmem code-location
175     (mkitem (tag (getmem code-location))
176      (compute-relocation reloc-tag reloc-inf code-base id-table))
177      )))
178%
179%
180(de relocate-right-half (code-location code-base id-table)
181  (let ((temp1 (halfword_getmem code-location))
182	(temp2 nil))
183       (setq temp2 (wand temp1 16#ffff))
184       (cond ((local-id-number? temp2)
185		(setq temp2 (local-to-global-id temp2 id-table))
186		(halfword_putmem code-location (wor (wand temp1 (wnot 16#ffff))
187		                           temp2))))))
188
189
190(de compute-relocation (reloc-tag reloc-inf code-base id-table)
191  (case reloc-tag
192    ((reloc-code-offset)  (wplus2 code-base reloc-inf ))
193    ((reloc-value-cell)
194     (cond ((local-id-number? reloc-inf)
195	      (loc (symval (local-to-global-id reloc-inf id-table))))
196	   (t (loc (symval reloc-inf)))))
197    ((reloc-function-cell)
198     (progn
199      (when (local-id-number? reloc-inf)
200	(setq reloc-inf (local-to-global-id reloc-inf id-table)))
201      (wplus2 symfnc                      %%% Should be (LOC (SYMFNC xxx)) ???
202	      (wtimes2 addressingunitsperfunctioncell reloc-inf))))
203    ((reloc-id-number)
204     (if (local-id-number? reloc-inf)
205       (local-to-global-id reloc-inf id-table)
206       reloc-inf
207       ))
208    ))
209
210(de local-to-global-id (local-id-number id-table)
211  (words-fetch id-table (wdifference local-id-number 2048))
212  )
213
214(de read-id-table (fid)
215  % Read in the table of local IDs at the front of the FASL file.
216  % Each ID is stored as one word which holds the length, followed
217  % by the appropriate number of words holding the string.
218
219  (let* ((local-id-count  (binaryread fid))
220	 (id-table        (mkwrds (gtwrds (wplus2 local-id-count 1)))))
221
222    (for
223     (from i 0 local-id-count)
224     (do (setf (wgetv tokenbuffer 0) (binaryread fid))
225			% word is length of ID name
226	 (binaryreadblock fid  (loc (wgetv tokenbuffer 1))
227		               (strpack (wgetv tokenbuffer 0)))
228	 (setf (words-fetch id-table i)
229	   (idinf (faslin-intern (mkstr (loc (wgetv tokenbuffer 0))))))
230	 ))
231    id-table
232    ))
233
234(de putentry (name type offset)
235  % Called by the initcode.
236  % CODE-BASE-HACK is set by FASLIN before the initcode is called.
237  (putd name type (mkcode (wplus2 code-base-hack offset) )))
238
239(de faslin-bad-file (name)    % To be redefined
240  (console-print-string "File is not FASL format")
241  (console-newline) )
242
243(de relocate-movex (code-location code-base id-table)
244    (let ((val (halfword_getmem (wplus2 code-location -4)))
245	  (add (halfword_getmem code-location))
246          (twentysix 26)
247	  (lui nil))
248	 (setq lui (wor (wshift 15 twentysix) % LIS instruction
249		        (wor (wand (wshift val -16) 16#ffff)
250		                  % pull the register out of next instr
251		             (wshift (wand (wshift add -21) 16#1f) 21))))
252	 (setq add (wor add (wand val 16#ffff)))
253	 % adjust in case of not oril instruction
254	 (when (and (eq 1 (wshift (wand val 16#ffff) -15))
255		    (not (eq 24 (wshift add -26)))) % 24 is ORIL opcode
256		        (setq lui (wplus2 1 lui)))
257	 (halfword_putmem (wplus2 code-location -4) lui)
258	 (halfword_putmem code-location add)))
259
260(de delbps (bottom top)      % returns space to Bps
261
262       (when (weq nextbps top)
263            (flushcache bottom (wdifference nextbps bottom) 1)
264            (setq nextbps bottom)))
265
266
267(lap '((*entry flushcache expr 3)
268       (icbi (reg 1) (reg r0)) % see instruction manual
269       (*exit 0)))
270
271(off fast-integers)
272