![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to nfasl.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to nfasl.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)nfasl.c 34.5 10/13/80";
2:
3: #include "global.h"
4: #include <sys/types.h>
5: #include <pagsiz.h>
6: #include "naout.h"
7: #include "chkrtab.h"
8: #include "structs.h"
9:
10: /* fasl - fast loader j.k.foderaro
11: * this loader is tuned for the lisp fast loading application
12: * any changes in the system loading procedure will require changes
13: * to this file
14: *
15: * The format of the object file we read as input:
16: * text segment:
17: * 1) program text - this comes first.
18: * 2) binder table - one word entries, see struct bindage
19: * begins with symbol: bind_org
20: * 3) litterals - exploded lisp objects.
21: * begins with symbol: lit_org
22: * ends with symbol: lit_end
23: * data segment:
24: * not used
25: *
26: *
27: * these segments are created permanently in memory:
28: * code segment - contains machine codes to evaluate lisp functions.
29: * linker segment - a list of pointers to lispvals. This allows the
30: * compiled code to reference constant lisp objects.
31: * The first word of the linker segment is a gc link
32: * pointer and does not point to a literal. The
33: * symbol binder is assumed to point to the second
34: * longword in this segment. The last word in the
35: * table is -1 as a sentinal to the gc marker.
36: * The number of real entries in the linker segment
37: * is given as the value of the linker_size symbol.
38: * Taking into account the 2 words required for the
39: * gc, there are 4*linker_size + 8 bytes in this segment.
40: * transfer segment - this is a transfer table block. It is used to
41: * allow compiled code to call other functions
42: * quickly. The number of entries in the transfer table is
43: * given as the value of the trans_size symbol.
44: *
45: * the following segments are set up in memory temporarily then flushed
46: * binder segment - a list of struct bindage entries. They describe
47: * what to do with the literals read from the literal
48: * table. The binder segment begins in the file
49: * following the bindorg symbol.
50: * literal segment - a list of characters which _Lread will read to
51: * create the lisp objects. The order of the literals
52: * is:
53: * linker literals - used to fill the linker segment.
54: * transfer table literals - used to fill the
55: * transfer segment
56: * binder literals - these include names of functions
57: * to bind interspersed with forms to evaluate.
58: * The meanings of the binder literals is given by
59: * the values in the binder segment.
60: * string segment - this is the string table from the file. We have
61: * to allocate space for it in core to speed up
62: * symbol referencing.
63: *
64: */
65:
66:
67: /* external functions called or referenced */
68:
69: lispval qcons(),qlinker(),qget();
70: int _qf0(), _qf1(), _qf2(), _qf3(), _qf4(), _qfuncl(), svkludg(),qnewint();
71: lispval Lread(), Lcons(), Lminus(), Ladd1(), Lsub1(), Lplist(), Lputprop();
72: lispval Lprint(), Lpatom(), Lconcat(), Lget(), Lmapc(), Lmapcan();
73: lispval Llist(), Ladd(), Lgreaterp(), Lequal(), Ltimes(), Lsub();
74: lispval Lncons();
75: lispval Idothrow(),error();
76: lispval Istsrch();
77: int mcount();
78: extern int mcounts[],mcountp,doprof;
79:
80: extern lispval *tynames[];
81: extern long errp;
82: extern char _erthrow[];
83: extern char setsav[];
84:
85: extern int initflag; /* when TRUE, inhibits gc */
86:
87: char *alloca(); /* stack space allocator */
88:
89: /* mini symbol table, contains the only external symbols compiled code
90: is allowed to reference
91: */
92:
93: #define SYMMAX 16
94: struct ssym { char *fnam; /* pointer to string containing name */
95: int floc; /* address of symbol */
96: int ord; /* ordinal number within cur sym tab */
97:
98: } Symbtb[SYMMAX]
99: = {
100: "trantb", 0, -1, /* must be first */
101: "linker", 0, -1, /* must be second */
102: "mcount", (int) mcount, -1,
103: "mcounts", (int) mcounts, -1,
104: "_qnewint", (int) qnewint, -1,
105: "_qcons", (int) qcons, -1,
106: "_typetable", (int) typetable, -1,
107: "_tynames", (int) tynames, -1,
108: "_qget", (int) qget, -1,
109: "_errp", (int) &errp, -1,
110: "_Idothrow", (int) Idothrow, -1,
111: "__erthrow", (int) _erthrow, -1,
112: "_error", (int) error, -1,
113: "_setsav", (int) setsav, -1,
114: "_svkludg", (int) svkludg, -1,
115: "_bnp", (int) &bnp, -1,
116: };
117:
118: struct nlist syml; /* to read a.out symb tab */
119: extern lispval *bind_lists; /* gc binding lists */
120:
121: /* bindage structure:
122: * the bindage structure describes the linkages of functions and name,
123: * and tells which functions should be evaluated. It is mainly used
124: * for the non-fasl'ing of files, we only use one of the fields in fasl
125: */
126: struct bindage
127: {
128: int b_type; /* type code, as described below */
129: };
130:
131: /* the possible values of b_type
132: * -1 - this is the end of the bindage entries
133: * 0 - this is a lambda function
134: * 1 - this is a nlambda function
135: * 2 - this is a macro function
136: * 99 - evaluate the string
137: *
138: */
139:
140:
141: extern struct trtab *trhead; /* head of list of transfer tables */
142: extern struct trent *trcur; /* next entry to allocate */
143: extern int trleft; /* # of entries left in this transfer table */
144:
145: struct trent *gettran(); /* function to allocate entries */
146:
147: /* maximum number of functions */
148: #define MAXFNS 500
149:
150: lispval Lnfasl()
151: {
152: extern int holend,usehole;
153: extern int uctolc;
154: extern char *curhbeg;
155: struct argent *svnp;
156: struct exec exblk; /* stores a.out header */
157: FILE *filp, *p, *map; /* file pointer */
158: int domap,note_redef;
159: lispval handy,debugmode;
160: struct relocation_info reloc;
161: struct trent *tranloc;
162: int trsize;
163: lispval disp;
164: int i,j,times, *iptr, oldinitflag;
165: int funloc[MAXFNS]; /* addresses of functions rel to txt org */
166: int funcnt = 0;
167:
168: /* symbols whose values are taken from symbol table of .o file */
169: int bind_org = 0; /* beginning of bind table */
170: int lit_org = 0; /* beginning of literal table */
171: int lit_end; /* end of literal table */
172: int trans_size = 0; /* size in entries of transfer table */
173: int linker_size; /* size in bytes of linker table
174: (not counting gc ptr) */
175:
176: /* symbols which hold the locations of the segments in core and
177: * in the file
178: */
179: char *code_core_org, /* beginning of code segment */
180: *linker_core_org, /* beginning of linker segment */
181: *linker_core_end, /* last word in linker segment */
182: *literal_core_org, /* beginning of literal table */
183: *binder_core_org, /* beginning of binder table */
184: *string_core_org;
185:
186: int string_file_org, /* location of string table in file */
187: string_size, /* number of chars in string table */
188: segsiz; /* size of permanent incore segment */
189:
190: char *symbol_name;
191: struct bindage *bindorg, *curbind;
192: int linkerloc, typer;
193: lispval rdform, *linktab;
194: int ouctolc;
195: int debug = 0;
196: lispval currtab,curibase;
197: char ch,*filnm;
198: char tempfilbf[100];
199:
200:
201: switch(np-lbot) {
202: case 0:
203: protect(nil);
204: case 1:
205: protect(nil);
206: case 2:
207: protect(nil);
208: case 3:
209: break;
210: default:
211: argerr("fasl");
212: }
213: filnm = (char *) verify(lbot->val,"fasl: non atom arg");
214:
215:
216: domap = FALSE;
217: /* debugging */
218: debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
219: /* end debugging */
220:
221:
222: /* insure that the given file name ends in .o
223: if it doesnt, copy to a new buffer and add a .o
224: */
225: tempfilbf[0] = '\0';
226: if( (i = strlen(filnm)) < 2 ||
227: strcmp(filnm+i-2,".o") != 0)
228: {
229: strcatn(tempfilbf,filnm,96);
230: strcat(tempfilbf,".o");
231: filnm = tempfilbf;
232: }
233:
234: if ( (filp = fopen(filnm,"r")) == NULL)
235: errorh(Vermisc,"Can't open file",nil,FALSE,9797,lbot->val);
236:
237: if ((handy = (lbot+1)->val) != nil )
238: {
239: if((TYPE(handy) != ATOM ) ||
240: (map = fopen(handy->a.pname,
241: (Istsrch(matom("appendmap"))->d.cdr->d.cdr->d.cdr == nil
242: ? "w" : "a"))) == NULL)
243: error("fasl: can't open map file",FALSE);
244: else
245: { domap = TRUE;
246: /* fprintf(map,"Map of file %s\n",lbot->val->a.pname); */
247: }
248: }
249:
250: /* set the note redefinition flag */
251: if((lbot+2)->val != nil) note_redef = TRUE;
252: else note_redef = FALSE;
253:
254: printf("[fasl %s]",filnm);
255: fflush(stdout);
256: svnp = np;
257:
258: lbot = np; /* set up base for later calls */
259:
260:
261: /* clear the ords in the symbol table */
262: for(i=0 ; i < SYMMAX ; i++) Symbtb[i].ord = -1;
263:
264: if( read(fileno(filp),&exblk,sizeof(struct exec))
265: != sizeof(struct exec))
266: error("fasl: header read failed",FALSE);
267:
268: /* check that the magic number is valid */
269:
270: if(exblk.a_magic != 0407) error("fasl: bad magic number in fasl file",FALSE);
271:
272: /* read in string table */
273: lseek(fileno(filp),(string_file_org = N_STROFF(exblk)),0);
274: if( read(fileno(filp), &string_size , 4) != 4)
275: error("fasl: string table read error, probably old fasl format", FALSE);
276:
277: /* allocate space for string table on the stack */
278: string_core_org = alloca(string_size - 4);
279:
280: if( read(fileno(filp), string_core_org , string_size - 4)
281: != string_size -4) error("fasl: string table read error ",FALSE);
282: /* read in symbol table and set the ordinal values */
283:
284: fseek(filp,N_SYMOFF(exblk),0);
285:
286: times = exblk.a_syms/sizeof(struct nlist);
287: if(debug) printf(" %d symbols in symbol table\n",times);
288:
289: for(i=0; i < times ; i++)
290: {
291: if( fread(&syml,sizeof(struct nlist),1,filp) != 1)
292: error("fasl: Symb tab read error",FALSE);
293:
294: symbol_name = syml.n_un.n_strx - 4 + string_core_org;
295: if (syml.n_type == N_EXT)
296: {
297: for(j=0; j< SYMMAX; j++)
298: {
299: if((Symbtb[j].ord < 0)
300: && strcmp(Symbtb[j].fnam,symbol_name)==0)
301: { Symbtb[j].ord = i;
302: if(debug)printf("symbol %s ord is %d\n",symbol_name,i);
303: break;
304: };
305:
306: };
307:
308: if( j>=SYMMAX ) printf("Unknown symbol %s\n",symbol_name);
309: }
310: else if (((ch = symbol_name[0]) == 's')
311: || (ch == 'L')
312: || (ch == '.') ) ; /* skip this */
313: else if (symbol_name[0] == 'F')
314: funloc[funcnt++] = syml.n_value; /* seeing function */
315: else if (!bind_org && (strcmp(symbol_name, "bind_org") == 0))
316: bind_org = syml.n_value;
317: else if (strcmp(symbol_name, "lit_org") == 0)
318: lit_org = syml.n_value;
319: else if (strcmp(symbol_name, "lit_end") == 0)
320: lit_end = syml.n_value;
321: else if (strcmp(symbol_name, "trans_size") == 0)
322: trans_size = syml.n_value;
323: else if (strcmp(symbol_name, "linker_size") == 0)
324: linker_size = syml.n_value;
325: }
326:
327: /* check to make sure we are working with the right format */
328: if((lit_org == 0) || (lit_end == 0))
329: errorh(Vermisc,"File not in new fasl format",nil,FALSE,0,lbot->val);
330:
331: /*----------------*/
332:
333: /* read in text segment up to beginning of binder table */
334:
335: segsiz = bind_org + 4*linker_size + 8 + 3; /* size is core segment size
336: * plus linker table size
337: * plus 2 for gc list
338: * plus 3 to round up to word
339: */
340:
341: lseek(fileno(filp),(long)sizeof(struct exec),0);
342: code_core_org = (char *) csegment(str_name,segsiz/4,TRUE);
343: if(read(fileno(filp),code_core_org,bind_org) != bind_org)
344: error("Read error in text ",FALSE);
345:
346: if(debug) {
347: printf("Read %d bytes of text into 0x%x\n",bind_org,code_core_org);
348: printf(" incore segment size: %d (0x%x)\n",segsiz,segsiz);
349: }
350:
351: /* linker table is 2 entries (8 bytes) larger than the number of
352: * entries given by linker_size . There must be a gc word at
353: * the beginning and a -1 at the end
354: */
355: linker_core_org = code_core_org + bind_org;
356: linker_core_end = linker_core_org + 4*linker_size + 4;
357: /* address of gc sentinal last */
358:
359: if(debug)printf("lin_cor_org: %x, link_cor_end %x\n",
360: linker_core_org,
361: linker_core_end);
362: Symbtb[1].floc = (int) (linker_core_org + 4);
363:
364: /* set the linker table to all -1's so we can put in the gc table */
365: for( iptr = (int *)(linker_core_org + 4 );
366: iptr <= (int *)(linker_core_end);
367: iptr++)
368: *iptr = -1;
369:
370:
371: /* link our table into the gc tables */
372: *(int *)linker_core_org = (int)bind_lists; /* point to current */
373: bind_lists = (lispval *) (linker_core_org + 4); /* point to first item */
374:
375: /* read the binder table and literals onto the stack */
376:
377: binder_core_org = alloca(lit_end - bind_org);
378: read(fileno(filp),binder_core_org,lit_end-bind_org);
379:
380: literal_core_org = binder_core_org + lit_org - bind_org;
381:
382: /* check if there is a transfer table required for this
383: * file, and if so allocate one of the necessary size
384: */
385:
386: if(trans_size > 0)
387: {
388: tranloc = gettran(trans_size);
389: Symbtb[0].floc = (int) tranloc;
390: }
391:
392: /* now relocate the necessary symbols in the text segment */
393:
394: fseek(filp,(long)(sizeof(struct exec) + exblk.a_text + exblk.a_data),0);
395: times = (exblk.a_trsize)/sizeof(struct relocation_info);
396:
397: /* the only symbols we will relocate are references to
398: external symbols. They are recognized by
399: extern and pcrel set.
400: */
401:
402: for( i=1; i<=times ; i++)
403: {
404: if( fread(&reloc,sizeof(struct relocation_info),1,filp) != 1)
405: error("Bad text reloc read",FALSE);
406: if(reloc.r_extern && reloc.r_pcrel)
407: {
408: for(j=0; j < SYMMAX; j++)
409: {
410:
411: if(Symbtb[j].ord == reloc.r_symbolnum) /* look for this sym */
412: {
413: if(debug && FALSE) printf("Relocating %d (ord %d) at %x\n",
414: j, Symbtb[j].ord, reloc.r_address);
415: if (Symbtb[j].floc == (int) mcounts) {
416: *(int *)(code_core_org+reloc.r_address)
417: += mcountp - (int)code_core_org;
418: if(doprof){
419: if (mcountp == (int) &mcounts[NMCOUNT-2])
420: printf("Ran out of counters; increas NMCOUNT in fasl.c\n");
421: if (mcountp < (int) &mcounts[NMCOUNT-1])
422: mcountp += 4;
423: }
424: } else
425: *(int *)(code_core_org+reloc.r_address)
426: += Symbtb[j].floc - (int)code_core_org;
427:
428: break;
429:
430: }
431: };
432: if( j >= SYMMAX) if(debug) printf("Couldnt find ord # %d\n",
433: reloc.r_symbolnum);
434: }
435:
436: }
437:
438: putchar('\n');
439: fflush(stdout);
440:
441: /* set up a fake port so we can read from core */
442: /* first find a free port */
443:
444: p = stdin;
445: for( ; p->_flag & (_IOREAD|_IOWRT) ; p++)
446: if( p >= _iob + _NFILE)
447: error(" No free file descriptor for fasl ",FALSE);
448:
449: p->_flag = _IOREAD | _IOSTRG;
450: p->_base = p->_ptr = (char *) literal_core_org; /* start at beginning of lit */
451: p->_cnt = lit_end - lit_org;
452:
453: if(debug)printf("lit_org %d, charstrt %d\n",lit_org, p->_base);
454: /* the first forms we wish to read are those literals in the
455: * literal table, that is those forms referenced by an offset
456: * from r8 in compiled code
457: */
458:
459: /* to read in the forms correctly, we must set up the read table
460: */
461: currtab = Vreadtable->a.clb;
462: Vreadtable->a.clb = strtab; /* standard read table */
463: curibase = ibase->a.clb;
464: ibase->a.clb = inewint(10); /* read in decimal */
465: ouctolc = uctolc; /* remember value of uctolc flag */
466:
467: oldinitflag = initflag; /* remember current val */
468: initflag = TRUE; /* turn OFF gc */
469: i = 1;
470: linktab = (lispval *)(linker_core_org +4);
471: while (linktab < (lispval *)linker_core_end)
472: {
473: np = svnp;
474: protect(P(p));
475: uctolc = FALSE;
476: handy = Lread();
477: uctolc = ouctolc;
478: getc(p); /* eat trailing blank */
479: if(debugmode)
480: { printf("form %d read: ",i++);
481: printr(handy,stdout);
482: putchar('\n');
483: fflush(stdout);
484: }
485: *linktab++ = handy;
486: }
487:
488: /* process the transfer table if one is used */
489: trsize = trans_size;
490: while(trsize--)
491: {
492: np = svnp;
493: protect(P(p));
494: uctolc = FALSE;
495: handy = Lread(); /* get function name */
496: uctolc = ouctolc;
497: getc(p);
498: tranloc->name = handy;
499: tranloc->fcn = qlinker; /* initially go to qlinker */
500: tranloc++;
501: }
502:
503:
504:
505: /* now process the binder table, which contains pointers to
506: functions to link in and forms to evaluate.
507: */
508: funcnt = 0;
509:
510: curbind = (struct bindage *) binder_core_org;
511: for( ; curbind->b_type != -1 ; curbind++)
512: {
513: np = svnp;
514: protect(P(p));
515: uctolc = FALSE; /* inhibit uctolc conversion */
516: rdform = Lread();
517: /* debugging */
518: if(debugmode) { printf("link form read: ");
519: printr(rdform,stdout);
520: printf(" ,type: %d\n",
521: curbind->b_type);
522: fflush(stdout);
523: }
524: /* end debugging */
525: uctolc = ouctolc; /* restore previous state */
526: getc(p); /* eat trailing null */
527: protect(rdform);
528: if(curbind->b_type <= 2) /* if function type */
529: {
530: handy = newfunct();
531: if (note_redef && (rdform->a.fnbnd != nil))
532: {
533: printr(rdform,stdout);
534: printf(" redefined\n");
535: }
536: rdform->a.fnbnd = handy;
537: handy->bcd.entry = (lispval (*)())(code_core_org + funloc[funcnt++]);
538: handy->bcd.discipline =
539: (curbind->b_type == 0 ? lambda :
540: curbind->b_type == 1 ? nlambda :
541: macro);
542: if(domap) fprintf(map,"%s\n%x\n",rdform->a.pname,handy->bcd.entry);
543: }
544: else {
545: Vreadtable->a.clb = currtab;
546: ibase->a.clb = curibase;
547:
548: /* debugging */
549: if(debugmode) {
550: printf("Eval: ");
551: printr(rdform,stdout);
552: printf("\n");
553: fflush(stdout);
554: };
555: /* end debugging */
556:
557: eval(rdform); /* otherwise eval it */
558:
559: if(uctolc) ouctolc = TRUE; /* if changed by eval, remember */
560: curibase = ibase->a.clb;
561: ibase->a.clb = inewint(10);
562: Vreadtable->a.clb = strtab;
563: }
564: };
565:
566: p->_cnt = p->_file = p->_flag = 0; /* give up file descriptor */
567: p->_ptr = p-> _base = (char *) 0;
568: initflag = oldinitflag; /* restore state of gc */
569: Vreadtable->a.clb = currtab;
570: chkrtab(currtab);
571: ibase->a.clb = curibase;
572:
573: fclose(filp);
574: if(domap) fclose(map);
575: return(tatom);
576: }
577:
578:
579: /* gettran :: allocate a segment of transfer table of the given size */
580:
581: struct trent *
582: gettran(size)
583: {
584: struct trtab *trp;
585: struct trent *retv;
586: int ousehole;
587: extern int usehole;
588:
589: if(size > TRENTS)
590: error("transfer table too large",FALSE);
591:
592: if(size > trleft)
593: {
594: /* allocate a new transfer table */
595: /* must not allocate in the hole or we cant modify it */
596: ousehole = usehole; /* remember old value */
597: usehole = FALSE;
598: trp = (struct trtab *)csegment(str_name,sizeof(struct trtab),FALSE);
599: usehole = ousehole;
600:
601: trp->sentinal = 0; /* make sure the sentinal is 0 */
602: trp->nxtt = trhead; /* link at beginning of table */
603: trhead = trp;
604: trcur = &(trp->trentrs[0]); /* begin allocating here */
605: trleft = TRENTS;
606: }
607:
608: trleft = trleft - size;
609: retv = trcur;
610: trcur = trcur + size;
611: return(retv);
612: }
613:
614: /* clrtt :: clear transfer tables, or link them all up;
615: * this has two totally opposite functions:
616: * 1) all transfer tables are reset so that all function calls will go
617: * through qlinker
618: * 2) as many transfer tables are set up to point to bcd functions
619: * as possible
620: */
621: clrtt(flag)
622: {
623: /* flag = 0 :: set to qlinker
624: * flag = 1 :: set to function bcd binding if possible
625: */
626: register struct trtab *temptt;
627: register struct trent *tement;
628: register lispval fnb;
629:
630: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt)
631: {
632: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++)
633: { if(flag == 0 || TYPE(fnb=tement->name->a.fnbnd) != BCD
634: || TYPE(fnb->bcd.discipline) == STRNG)
635: tement->fcn = qlinker;
636: else tement->fcn = fnb->bcd.entry;
637: }
638: }
639: }
640:
641: /* chktt - builds a list of transfer table entries which don't yet have
642: a function associated with them, i.e if this transfer table entry
643: were used, an undefined function error would result
644: */
645: lispval
646: chktt()
647: {
648: register struct trtab *temptt;
649: register struct trent *tement;
650: register lispval retlst,curv;
651:
652: snpand(4);
653:
654: retlst = newdot(); /* build list of undef functions */
655: protect(retlst);
656: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt)
657: {
658: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++)
659: {
660: if(tement->name->a.fnbnd == nil)
661: {
662: curv= newdot();
663: curv->d.car = tement->name;
664: curv->d.cdr = retlst->d.cdr;
665: retlst->d.cdr = curv;
666: }
667: }
668: }
669: return(retlst->d.cdr);
670: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.