![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rfasl.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp|
Return to rfasl.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 root 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.