Commit | Line | Data |
---|---|---|
54a34c11 JF |
1 | #include "global.h" |
2 | #include <stdio.h> | |
3 | #include <a.out.h> | |
4 | #include "chkrtab.h" | |
5 | ||
6 | /* rfasl - really fast loader j.k.foderaro | |
7 | * this loader is tuned for the lisp fast loading application | |
8 | * any changes in the system loading procedure will require changes | |
9 | * to this file | |
10 | * Nov 4, 1979 - this now becomes fasl to the lisp world | |
11 | */ | |
12 | ||
13 | ||
14 | ||
15 | /* global variables to keep track of allocation */ | |
16 | ||
17 | int curps ; | |
18 | ||
19 | /* external functions called or referenced */ | |
20 | ||
21 | int _qf0(), _qf1(), _qf2(), _qf3(), _qf4(), _qfuncl(), svkludg(); | |
22 | lispval Lread(), Lcons(), Lminus(), Ladd1(), Lsub1(), Lplist(), Lputprop(); | |
23 | lispval Lprint(), Lpatom(), Lconcat(), Lget(), Lmapc(), Lmapcan(); | |
24 | lispval Llist(), Ladd(), Lgreaterp(), Lequal(), Ltimes(), Lsub(); | |
25 | lispval Lncons(); | |
26 | lispval Idothrow(),error(); | |
27 | extern lispval *tynames[]; | |
28 | extern int errp; | |
29 | extern char _erthrow[]; | |
30 | extern char setsav[]; | |
31 | ||
32 | extern int initflag; /* when TRUE, inhibits gc */ | |
33 | /* prelud to linker table in data segment | |
34 | * these locations always begin the data segment, if there is any change | |
35 | * to the compiler, this must be fixed up. | |
36 | * | |
37 | */ | |
38 | ||
39 | ||
40 | #define PRESIZ (8*4) | |
41 | ||
42 | struct prelud | |
43 | { | |
44 | int dummy[PRESIZ/4]; | |
45 | } prel = { | |
46 | (int) &bnp, | |
47 | (int) _qfuncl, | |
48 | (int) _qf4, | |
49 | (int) _qf3, | |
50 | (int) _qf2, | |
51 | (int) _qf1, | |
52 | (int) _qf0, | |
53 | (int) 0 }; | |
54 | /* mini symbol table, contains the only external symbols compiled code | |
55 | is allowed to reference | |
56 | */ | |
57 | ||
58 | #define SYMMAX 35 | |
59 | struct ssym { char *fnam; /* pointer to string containing name */ | |
60 | int floc; /* address of symbol */ | |
61 | int ord; /* ordinal number within cur sym tab */ | |
62 | ||
63 | } symbtb[SYMMAX] | |
64 | = { | |
65 | "_Lminus", (int) Lminus, -1, | |
66 | "_Ladd1", (int) Ladd1, -1, | |
67 | "_Lsub1", (int) Lsub1, -1, | |
68 | "_Lplist", (int) Lplist, -1, | |
69 | "_Lcons", (int) Lcons, -1, | |
70 | "_Lputpro", (int) Lputprop, -1, | |
71 | "_Lprint", (int) Lprint, -1, | |
72 | "_Lpatom", (int) Lpatom, -1, | |
73 | "_Lread", (int) Lread, -1, | |
74 | "_Lconcat", (int) Lconcat, -1, | |
75 | "_Lget", (int) Lget, -1, | |
76 | "_Lmapc", (int) Lmapc, -1, | |
77 | "_Lmapcan", (int) Lmapcan, -1, | |
78 | "_Llist", (int) Llist, -1, | |
79 | "_Ladd", (int) Ladd, -1, | |
80 | "_Lgreate",(int) Lgreaterp,-1, | |
81 | "_Lequal", (int) Lequal, -1, | |
82 | "_Ltimes", (int) Ltimes, -1, | |
83 | "_Lsub", (int) Lsub, -1, | |
84 | "_Lncons", (int) Lncons, -1, | |
85 | "_typetab", (int) typetab, -1, | |
86 | "_tynames", (int) tynames, -1, | |
87 | "_errp", (int) &errp, -1, | |
88 | "_Idothro", (int) Idothrow, -1, | |
89 | "__erthro", (int) _erthrow, -1, | |
90 | "_error", (int) error, -1, | |
91 | "_bnp", (int) &bnp, -1, | |
92 | "__qfuncl", (int) _qfuncl, -1, | |
93 | "__qf4", (int) _qf4, -1, | |
94 | "__qf3", (int) _qf3, -1, | |
95 | "__qf2", (int) _qf2, -1, | |
96 | "__qf1", (int) _qf1, -1, | |
97 | "__qf0", (int) _qf0, -1, | |
98 | "_setsav", (int) setsav, -1, | |
99 | "_svkludg", (int) svkludg, -1 | |
100 | }; | |
101 | ||
102 | struct nlist syml; /* to read a.out symb tab */ | |
103 | extern lispval *bind_lists; /* gc binding lists */ | |
104 | ||
105 | /* bindage structure: | |
106 | * the bindage structure describes the linkages of functions and name, | |
107 | * and tells which functions should be evaluated. It is mainly used | |
108 | * for the non-fasl'ing of files, we only use one of the fields in fasl | |
109 | */ | |
110 | struct bindage | |
111 | { | |
112 | lispval (*b_entry)(); /* function entry point */ | |
113 | int b_atmlnk; /* pointer to string */ | |
114 | int b_type; /* type code, as described below */ | |
115 | }; | |
116 | ||
117 | /* the possible values of b_type | |
118 | * -1 - this is the end of the bindage entries | |
119 | * 0 - this is a lambda function | |
120 | * 1 - this is a nlambda function | |
121 | * 2 - this is a macro function | |
122 | * 99 - evaluate the string | |
123 | * | |
124 | */ | |
125 | ||
126 | /* maximum number of functions */ | |
127 | #define MAXFNS 500 | |
128 | ||
129 | lispval Lfasl() | |
130 | { | |
131 | register int orgtx,orgdt,orgps; | |
132 | register struct argent *svnp, *lbot, *np; | |
133 | struct exec exblk; /* stores a.out header */ | |
134 | FILE *filp, *p, *map; /* file pointer */ | |
135 | int domap; | |
136 | lispval handy; | |
137 | struct relocation_info reloc; | |
138 | struct prelud *ppre; | |
139 | lispval disp; | |
140 | int i,j,times, *iptr, oldinitflag; | |
141 | int funloc[MAXFNS]; /* addresses of functions rel to txt org */ | |
142 | int funcnt = 0; | |
143 | ||
144 | /* unrelocated start and end of litteral table */ | |
145 | int litstrt = 0 , litend = 0; | |
146 | ||
147 | int segdif; | |
148 | struct bindage *bindorg, *curbind; | |
149 | int linkerloc, bindloc = 0 , typer,linkstrt,linkend; | |
150 | lispval rdform, *linktab; | |
151 | int segsiz; | |
152 | int debug = 0; | |
153 | lispval currtab,curibase; | |
154 | char ch; | |
155 | ||
156 | ||
157 | chkarg(2); | |
158 | if (TYPE(lbot->val) != ATOM) error("non atom arg",FALSE); | |
159 | ||
160 | if ( (filp = fopen((lbot->val)->pname,"r")) == NULL) | |
161 | errorh(Vermisc,"Can't open file",nil,FALSE,9797,lbot->val); | |
162 | ||
163 | domap = FALSE; | |
164 | if ((handy = (lbot+1)->val) != nil ) | |
165 | { | |
166 | if((TYPE(handy) != ATOM ) || | |
167 | (map = fopen(handy->pname,"w")) == NULL) | |
168 | error("rfasl: can't open map file",FALSE); | |
169 | else | |
170 | { domap = TRUE; | |
171 | fprintf(map,"Map of file %s\n",lbot->val->pname); | |
172 | } | |
173 | } | |
174 | ||
175 | printf("[fasl %s]",lbot->val->pname); | |
176 | fflush(stdout); | |
177 | svnp = np; | |
178 | ||
179 | lbot = np; /* set up base for later calls */ | |
180 | ||
181 | ||
182 | /* clear the ords in the symbol table */ | |
183 | for(i=0 ; i < SYMMAX ; i++) symbtb[i].ord = -1; | |
184 | ||
185 | if( fread(&exblk,sizeof(struct exec),1,filp) != 1) | |
186 | error("Read failed",FALSE); | |
187 | ||
188 | ||
189 | /* read in symbol table and set the ordinal values */ | |
190 | ||
191 | fseek(filp, | |
192 | (long)(32+exblk.a_text+exblk.a_data+exblk.a_trsize+exblk.a_drsize) | |
193 | ,0); | |
194 | ||
195 | times = exblk.a_syms/sizeof(struct nlist); | |
196 | if(debug) printf(" %d symbols in symbol table\n",times); | |
197 | ||
198 | for(i=0; i < times ; i++) | |
199 | { | |
200 | if( fread(&syml,sizeof(struct nlist),1,filp) != 1) | |
201 | ||
202 | ||
203 | error("Symb tab read error",FALSE); | |
204 | ||
205 | if (syml.n_type == N_EXT) | |
206 | { | |
207 | for(j=0; j< SYMMAX; j++) | |
208 | { | |
209 | if((symbtb[j].ord < 0) | |
210 | && strcmpn(symbtb[j].fnam,syml.n_name,8)==0) | |
211 | { symbtb[j].ord = i; | |
212 | if(debug)printf("symbol %s ord is %d\n",syml.n_name,i); | |
213 | break; | |
214 | }; | |
215 | ||
216 | }; | |
217 | ||
218 | if( j>=SYMMAX ) printf("Unknown symbol %s\n",syml.n_name); | |
219 | } | |
220 | else if (((ch = syml.n_name[0]) == 's') | |
221 | || (ch == 'L') | |
222 | || (ch == '.') ) ; /* skip this */ | |
223 | else if (syml.n_name[0] == 'F') | |
224 | funloc[funcnt++] = syml.n_value; /* seeing function */ | |
225 | else if (!bindloc && (strcmp(syml.n_name, "BINDER") == 0)) | |
226 | bindloc = syml.n_value; | |
227 | else if (strcmp(syml.n_name, "litstrt") == 0) | |
228 | litstrt = syml.n_value; | |
229 | else if (strcmp(syml.n_name, "litend") == 0) | |
230 | litend = syml.n_value; | |
231 | } | |
232 | ||
233 | /* check to make sure we are working with the right format */ | |
234 | if((litstrt == 0) || (litend == 0)) | |
235 | errorh(Vermisc,"File not in new fasl format",nil,FALSE,0,lbot->val); | |
236 | ||
237 | /*----------------*/ | |
238 | ||
239 | /* read in text segment */ | |
240 | ||
241 | ||
242 | fseek(filp,(long)32,0); | |
243 | segsiz = exblk.a_text + exblk.a_data; | |
244 | if(fread(curps = (int) csegment(int_name,segsiz/sizeof(int)) | |
245 | ,1,exblk.a_text,filp) != exblk.a_text) | |
246 | error("Read error in text and data read",FALSE); | |
247 | ||
248 | orgtx = curps; | |
249 | orgdt = curps + exblk.a_text; | |
250 | ||
251 | linkstrt = orgdt + PRESIZ; /* start of linker table */ | |
252 | linkend = orgdt + exblk.a_data - 4; /* end of linker table */ | |
253 | ||
254 | /* the object file is a 410 file and thus has seperate text and | |
255 | data segments. The data is assumed to be loaded at the start | |
256 | of the next PAGSIZ byte boundary, we must calculate the difference | |
257 | between where the data segment begins and where the loader | |
258 | thinks it begins. Caclulate by rounding up the text size and | |
259 | seeing how much is skipped | |
260 | */ | |
261 | segdif = ((exblk.a_text + PAGRND) & ~PAGRND) - exblk.a_text; | |
262 | if(debug) printf("funcs %d, orgtx %x, orgdt %x, linkstrt %x, linkend %x segdif %x", | |
263 | funcnt,orgtx,orgdt,linkstrt,linkend,segdif); | |
264 | ||
265 | /* set the linker table to all -1's so we can put in the gc table */ | |
266 | for( iptr = (int *)linkstrt ; iptr <= (int *)linkend ; iptr++) | |
267 | *iptr = -1; | |
268 | ||
269 | /* copy in the prelud */ | |
270 | ppre = (struct prelud *) orgdt; /* use structure to copy */ | |
271 | *ppre = prel; /* copy over prelud */ | |
272 | ||
273 | /* link our table into the gc tables */ | |
274 | *( ((int *)linkstrt) -1) = (int)bind_lists; /* point to current */ | |
275 | bind_lists = (lispval *) linkstrt; | |
276 | ||
277 | /* new relocate the necessary symbols in the text segment */ | |
278 | ||
279 | orgps = orgtx; | |
280 | fseek(filp,(long)(32+exblk.a_text+exblk.a_data),0); | |
281 | times = (exblk.a_trsize)/sizeof(struct relocation_info); | |
282 | ||
283 | /* the only symbols we will relocate are references to lisp | |
284 | 1) functions like _Lcons | |
285 | 2) the symbol linker in the data segment | |
286 | ||
287 | type (1) can be recognized by extern and pcrel, while | |
288 | type (2) can be recognized by !extern and pcrel and data segment | |
289 | */ | |
290 | ||
291 | for( i=1; i<=times ; i++) | |
292 | { | |
293 | if( fread(&reloc,sizeof(struct relocation_info),1,filp) != 1) | |
294 | error("Bad text reloc read",FALSE); | |
295 | if(reloc.r_extern && reloc.r_pcrel) | |
296 | { | |
297 | for(j=0; j < SYMMAX; j++) | |
298 | { | |
299 | ||
300 | if(symbtb[j].ord == reloc.r_symbolnum) /* look for this sym */ | |
301 | { | |
302 | if(debug) printf("Relocating %d (ord %d) at %x\n", | |
303 | j, symbtb[j].ord, reloc.r_address); | |
304 | *(int *)(orgps+reloc.r_address) | |
305 | += symbtb[j].floc - orgtx; | |
306 | ||
307 | break; | |
308 | ||
309 | } | |
310 | }; | |
311 | if( j >= SYMMAX) if(debug) printf("Couldnt find ord # %d\n", | |
312 | reloc.r_symbolnum); | |
313 | } | |
314 | else if(!reloc.r_extern && reloc.r_pcrel && | |
315 | (reloc.r_symbolnum == N_DATA)) | |
316 | { if(debug) printf("relocing at addr %x \n",reloc.r_address); | |
317 | *(int *)(orgps + reloc.r_address) -= segdif; | |
318 | } | |
319 | ||
320 | } | |
321 | ||
322 | putchar('\n'); | |
323 | fflush(stdout); | |
324 | ||
325 | /* set up a fake port so we can read from core */ | |
326 | /* first find a free port */ | |
327 | ||
328 | p = stdin; | |
329 | for( ; p->_flag & (_IOREAD|_IOWRT) ; p++) | |
330 | if( p >= _iob + _NFILE) | |
331 | error(" No free file descriptor for fasl ",FALSE); | |
332 | ||
333 | p->_flag = _IOREAD | _IOSTRG; | |
334 | p->_base = p->_ptr = (char *) (orgtx + litstrt); /* start at beginning of lit */ | |
335 | p->_cnt = litend - litstrt; | |
336 | ||
337 | if(debug)printf("litstrt %d, charstrt %d\n",litstrt, p->_base); | |
338 | /* the first forms we wish to read are those literals in the | |
339 | * literal table, that is those forms referenced by an offset | |
340 | * from r8 in compiled code | |
341 | */ | |
342 | ||
343 | /* to read in the forms correctly, we must set up the read table | |
344 | */ | |
345 | currtab = Vreadtable->clb; | |
346 | Vreadtable->clb = strtab; /* standard read table */ | |
347 | curibase = ibase->clb; | |
348 | ibase->clb = inewint(10); /* read in decimal */ | |
349 | ||
350 | linktab = (lispval *)linkstrt; | |
351 | ||
352 | oldinitflag = initflag; /* remember current val */ | |
353 | initflag = TRUE; /* turn OFF gc */ | |
354 | ||
355 | while (linktab < (lispval *)linkend) | |
356 | { | |
357 | np = svnp; | |
358 | protect(P(p)); | |
359 | handy = Lread(); | |
360 | getc(p); /* eat trailing blank */ | |
361 | if(debug) | |
362 | { printf("one form read: "); | |
363 | printr(handy,stdout); fflush(stdout); | |
364 | } | |
365 | *linktab++ = handy; | |
366 | } | |
367 | ||
368 | /* now process the binder table, which contains pointers to | |
369 | functions to link in and forms to evaluate. | |
370 | */ | |
371 | bindorg = (struct bindage *) (orgtx + bindloc); | |
372 | funcnt = 0; | |
373 | if(debug) printf("binding loc %d, orgin : %d\n",bindloc,bindorg); | |
374 | ||
375 | for( curbind = bindorg; curbind->b_type != -1 ; curbind++) | |
376 | { | |
377 | np = svnp; | |
378 | protect(P(p)); | |
379 | rdform = Lread(); | |
380 | getc(p); /* eat trailing null */ | |
381 | protect(rdform); | |
382 | if(curbind->b_type <= 2) /* if function type */ | |
383 | { | |
384 | handy = newfunct(); | |
385 | rdform->fnbnd = handy; | |
386 | handy->entry = (lispval (*)())(orgtx + funloc[funcnt++]); | |
387 | handy->discipline = | |
388 | (curbind->b_type == 0 ? lambda : | |
389 | curbind->b_type == 1 ? nlambda : | |
390 | macro); | |
391 | if(domap) fprintf(map,"%s\n%x\n",rdform->pname,handy->entry); | |
392 | } | |
393 | else { | |
394 | Vreadtable->clb = currtab; | |
395 | ibase->clb = curibase; | |
396 | ||
397 | eval(rdform); /* otherwise eval it */ | |
398 | ||
399 | curibase = ibase->clb; | |
400 | ibase->clb = inewint(10); | |
401 | Vreadtable->clb = strtab; | |
402 | } | |
403 | }; | |
404 | ||
405 | p->_flag = 0; /* give up file descriptor */ | |
406 | initflag = oldinitflag; /* restore state of gc */ | |
407 | Vreadtable->clb = currtab; | |
408 | chkrtab(currtab); | |
409 | ibase->clb = curibase; | |
410 | ||
411 | fclose(filp); | |
412 | if(domap) fclose(map); | |
413 | return(tatom); | |
414 | } | |
415 |