Return to rfasl.c CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / lisp

Annotation of 3BSD/cmd/lisp/rfasl.c, revision 1.1

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.