![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to qfuncl.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz / tahoe|
Return to qfuncl.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz / tahoe |
1.1 ! root 1: /* ! 2: * qfuncl.c ! 3: * lisp to C interface ! 4: * ! 5: * (c) copyright 1982, Regents of the University of California ! 6: * ! 7: * This is written in assembler but must be passed through the C preprocessor ! 8: * before being assembled. ! 9: */ ! 10: ! 11: #include "ltypes.h" ! 12: #include "config.h" ! 13: ! 14: /* important offsets within data types for atoms */ ! 15: #define Atomfnbnd 8 ! 16: ! 17: /* for arrays */ ! 18: #define Arrayaccfun 0 ! 19: ! 20: #ifdef PROF ! 21: .set indx,0 ! 22: #define Profile \ ! 23: movab prbuf+indx,r0 \ ! 24: .set indx,indx+4 \ ! 25: jsb mcount ! 26: #define Profile2 \ ! 27: movl r0,r5 \ ! 28: Profile \ ! 29: movl r5,r0 ! 30: #else ! 31: #define Profile ! 32: #define Profile2 ! 33: #endif ! 34: ! 35: #ifdef PORTABLE ! 36: #define NIL _nilatom ! 37: #define NP _np ! 38: #define LBOT _lbot ! 39: #else ! 40: #define NIL 0 ! 41: #define NP r6 ! 42: #define LBOT r7 ! 43: #endif ! 44: ! 45: ! 46: /* transfer table linkage routine */ ! 47: ! 48: .globl _qlinker ! 49: _qlinker: ! 50: .word 0x1fc0 # save all possible registers ! 51: Profile ! 52: tstl _exception # any pending exceptions ! 53: jeql noexc ! 54: tstl _sigintcnt # is it because of SIGINT ! 55: jeql noexc # if not, just leave ! 56: pushl $2 # else push SIGINT ! 57: callf $8,_sigcall ! 58: noexc: ! 59: movl r2, r0 # stick linktable entry in r0 ! 60: movl 4(r2),r1 # get atom pointer ! 61: retry: # come here after undef func error ! 62: movl Atomfnbnd(r1),r2 # get function binding ! 63: jleq nonex # if none, leave ! 64: tstl _stattab+2*4 # see if linking possible (Strans) ! 65: jeql nolink # no, it isn't ! 66: shar $9,r2,r3 # check type of function ! 67: cmpb $BCD,_typetable+1[r3] ! 68: jeql linkin # bcd, link it in! ! 69: cmpb $ARRAY,_typetable+1[r3] # how about array? ! 70: jeql doarray # yep ! 71: ! 72: ! 73: nolink: ! 74: pushl r1 # non, bcd, call interpreter ! 75: callf $8,_Ifuncal ! 76: ret ! 77: ! 78: /* ! 79: * handle arrays by pushing the array descriptor on the table and checking ! 80: * for a bcd array handler ! 81: */ ! 82: doarray: ! 83: shar $9,Arrayaccfun(r2),r3 # get access function addr shifted ! 84: cmpb $/**/BCD,_typetable+1[r3] # bcd?? ! 85: jneq nolink # no, let funcal handle it ! 86: #ifdef PORTABLE ! 87: movl NP,r4 ! 88: movl r2,(r4)+ # store array header on stack ! 89: movl r4,NP ! 90: #else ! 91: movl r2,(r6) # store array header on stack ! 92: addl2 $4, r6 ! 93: #endif ! 94: movl *(r2),r2 # get in func addr ! 95: jmp 2(r2) # jump in beyond calls header ! 96: ! 97: ! 98: linkin: ! 99: shar $9,4(r2),r3 # check type of function discipline ! 100: cmpb $0,_typetable+1[r3] # is it string? ! 101: jeql nolink # yes, it is a c call, so dont link in ! 102: movl (r2),r2 # get function addr ! 103: movl r2,(r0) # put fcn addr in table ! 104: jmp 2(r2) # enter fcn after mask ! 105: ! 106: nonex: pushl r0 # preserve table address ! 107: pushl r1 # non existant fcn ! 108: callf $8,_Undeff # call processor ! 109: movl r0,r1 # back in r1 ! 110: movl (sp)+,r0 # restore table address ! 111: jbr retry # for the retry. ! 112: ! 113: ! 114: .globl __erthrow # errmessage for uncaught throws ! 115: __erthrow: ! 116: .asciz "Uncaught throw from compiled code" ! 117: ! 118: .align 2 ! 119: .globl _tynames ! 120: _tynames: ! 121: .long NIL # nothing here ! 122: .long _lispsys+20*4 # str_name ! 123: .long _lispsys+21*4 # atom_name ! 124: .long _lispsys+19*4 # int_name ! 125: .long _lispsys+23*4 # dtpr_name ! 126: .long _lispsys+22*4 # doub_name ! 127: .long _lispsys+58*4 # funct_name ! 128: .long _lispsys+103*4 # port_name ! 129: .long _lispsys+47*4 # array_name ! 130: .long NIL # nothing here ! 131: .long _lispsys+50*4 # sdot_name ! 132: .long _lispsys+53*4 # val_nam ! 133: .long NIL # hunk2_nam ! 134: .long NIL # hunk4_nam ! 135: .long NIL # hunk8_nam ! 136: .long NIL # hunk16_nam ! 137: .long NIL # hunk32_nam ! 138: .long NIL # hunk64_nam ! 139: .long NIL # hunk128_nam ! 140: .long _lispsys+124*4 # vector_nam ! 141: .long _lispsys+125*4 # vectori_nam ! 142: ! 143: /* Quickly allocate small fixnums */ ! 144: ! 145: .globl _qnewint ! 146: _qnewint: ! 147: .word 0 ! 148: Profile ! 149: cmpl r5,$1024 ! 150: jgeq alloc ! 151: cmpl r5,$-1024 ! 152: jlss alloc ! 153: moval _Fixzero[r5],r0 ! 154: ret ! 155: alloc: ! 156: movl _int_str,r0 # move next cell addr to r0 ! 157: jlss callnewi # if no space, allocate ! 158: incl *_lispsys+24*4 # inc count of ints ! 159: movl (r0),_int_str # advance free list ! 160: movl r5,(r0) # put baby to bed. ! 161: ret ! 162: callnewi: ! 163: pushl r5 ! 164: callf $4,_newint ! 165: movl (sp)+,(r0) ! 166: ret ! 167: ! 168: ! 169: /* _qoneplus adds one to the boxed fixnum in r0 ! 170: * and returns a boxed fixnum. ! 171: */ ! 172: ! 173: .globl _qoneplus ! 174: _qoneplus: ! 175: .word 0 ! 176: Profile2 ! 177: addl3 (r0),$1,r5 ! 178: #ifdef PORTABLE ! 179: movl r6,NP ! 180: movl r6,LBOT ! 181: #endif ! 182: jmp _qnewint+2 ! 183: ! 184: /* _qoneminus subtracts one from the boxes fixnum in r0 and returns a ! 185: * boxed fixnum ! 186: */ ! 187: .globl _qoneminus ! 188: _qoneminus: ! 189: .word 0 ! 190: Profile2 ! 191: subl3 $1,(r0),r5 ! 192: #ifdef PORTABLE ! 193: movl r6,NP ! 194: movl r6,LBOT ! 195: #endif ! 196: jmp _qnewint+2 ! 197: ! 198: /* ! 199: * _qnewdoub quick allocation of a initialized double (float) cell. ! 200: * This entry point is required by the compiler for symmetry reasons. ! 201: * Passed to _qnewdoub in r4,r5 is a double precision floating point ! 202: * number. This routine allocates a new cell, initializes it with ! 203: * the given value and then returns the cell. ! 204: */ ! 205: ! 206: .globl _qnewdoub ! 207: _qnewdoub: ! 208: .word 0 ! 209: Profile ! 210: movl _doub_str,r0 # move next cell addr to r0 ! 211: jlss callnewd # if no space, allocate ! 212: incl *_lispsys+30*4 # inc count of doubs ! 213: movl (r0),_doub_str # advance free list ! 214: movl r4,(r0) # put baby to bed. ! 215: movl r5,4(r0) #was movq r4,(r0) ! 216: ret ! 217: ! 218: callnewd: ! 219: pushl r5 # stack initial value ! 220: pushl r4 ! 221: callf $4,_newdoub ! 222: movl (sp)+, (r0) # restore initial value ! 223: movl (sp)+, 4(r0) ! 224: ret ! 225: ! 226: .globl _qcons ! 227: ! 228: /* ! 229: * quick cons call, the car and cdr are stacked on the namestack ! 230: * and this function is jsb'ed to. ! 231: */ ! 232: ! 233: _qcons: ! 234: .word 0 ! 235: Profile ! 236: movl _dtpr_str,r0 # move next cell addr to r0 ! 237: jlss getnew # if ran out of space jump ! 238: incl *_lispsys+28*4 # inc count of dtprs ! 239: movl (r0),_dtpr_str # advance free list ! 240: storit: ! 241: subl2 $8,r6 ! 242: movl 4(r6),(r0) # store in cdr ! 243: movl (r6),4(r0) # store in car ! 244: ret ! 245: ! 246: getnew: ! 247: #ifdef PORTABLE ! 248: movl r6,NP ! 249: movab -8(r6),LBOT ! 250: #endif ! 251: callf $4,_newdot # must gc to get one ! 252: jbr storit # now initialize it. ! 253: ! 254: /* ! 255: * Fast equivalent of newdot, no longer entered by jsb ! 256: */ ! 257: ! 258: .globl _qnewdot ! 259: _qnewdot: ! 260: .word 0 ! 261: Profile ! 262: movl _dtpr_str,r0 # mov next cell addr t0 r0 ! 263: jlss mustallo # if ran out of space ! 264: incl *_lispsys+28*4 # inc count of dtprs ! 265: movl (r0),_dtpr_str # advance free list ! 266: clrl (r0) # replaces clrq ! 267: clrl 4(r0) ! 268: ret ! 269: mustallo: ! 270: callf $4,_newdot ! 271: ret ! 272: ! 273: /* prunel - return a list of dtpr cells to the free list ! 274: * this is called by the pruneb after it has discarded the top bignum ! 275: * the dtpr cells are linked through their cars not their cdrs. ! 276: * this returns with an ret ! 277: * ! 278: * method of operation: the dtpr list we get is linked by car's so we ! 279: * go through the list and link it by cdr's, then have the last dtpr ! 280: * point to the free list and then make the free list begin at the ! 281: * first dtpr. ! 282: */ ! 283: qprunel: ! 284: movl r0,r2 # remember first dtpr location ! 285: rep: decl *_lispsys+28*4 # decrement used dtpr count ! 286: movl 4(r0),r1 # put link value into r1 ! 287: jeql endoflist # if nil, then end of list ! 288: movl r1,(r0) # repl cdr w/ save val as car ! 289: movl r1,r0 # advance to next dtpr ! 290: jbr rep # and loop around ! 291: endoflist: ! 292: movl _dtpr_str,(r0) # make last 1 pnt to free list ! 293: movl r2,_dtpr_str # & free list begin at 1st 1 ! 294: ret ! 295: ! 296: /* ! 297: * qpruneb - called by the arithmetic routines to free an sdot and the dtprs ! 298: * which hang on it. ! 299: * called by ! 300: * pushl sdotaddr ! 301: * jsb _qpruneb ! 302: */ ! 303: .globl _qpruneb ! 304: _qpruneb: ! 305: .word 0 ! 306: Profile ! 307: movl 4(sp),r0 # get address ! 308: decl *_lispsys+48*4 # decr count of used sdots ! 309: movl _sdot_str,(r0) # have new sdot point to free list ! 310: movl r0,_sdot_str # start free list at new sdot ! 311: movl 4(r0),r0 # get address of first dtpr ! 312: jneq qprunel # if exists, prune it ! 313: ret # else return. ! 314: ! 315: ! 316: /* ! 317: * _qprunei ! 318: * called by the arithmetic routines to free a fixnum cell ! 319: * calling sequence ! 320: * pushl fixnumaddr ! 321: * jsb _qprunei ! 322: */ ! 323: ! 324: .globl _qprunei ! 325: _qprunei: ! 326: .word 0 ! 327: Profile ! 328: movl 4(sp),r0 # get address of fixnum ! 329: cmpl r0,$_Lastfix # is it a small fixnum ! 330: jleq skipit # if so, leave ! 331: decl *_lispsys+24*4 # decr count of used ints ! 332: movl _int_str,(r0) # link the fixnum into the free list ! 333: movl r0,_int_str ! 334: skipit: ! 335: ret ! 336: ! 337: ! 338: .globl _qpopnames ! 339: _qpopnames: # equivalent of C-code popnames, entered by jsb. ! 340: .word 0 ! 341: movl (sp)+,r0 # return address ! 342: movl (sp)+,r1 # Lower limit ! 343: movl _bnp,r2 # pointer to bind stack entry ! 344: qploop: ! 345: subl2 $8,r2 # for(; (--r2) > r1;) { ! 346: cmpl r2,r1 # test for done ! 347: jlss qpdone ! 348: movl (r2),*4(r2) # r2->atm->a.clb = r2 -> val; ! 349: brb qploop # } ! 350: qpdone: ! 351: movl r1,_bnp # restore bnp ! 352: jmp (r0) # return ! 353: ! 354: /* ! 355: * _qget : fast get subroutine ! 356: * (get 'atom 'ind) ! 357: * called with -8(r6) equal to the atom ! 358: * -4(r6) equal to the indicator ! 359: * no assumption is made about LBOT ! 360: * unfortunately, the atom may not in fact be an atom, it may ! 361: * be a list or nil, which are special cases. ! 362: * For nil, we grab the nil property list (stored in a special place) ! 363: * and for lists we punt and call the C routine since it is most likely ! 364: * and error and we havent put in error checks yet. ! 365: */ ! 366: ! 367: .globl _qget ! 368: _qget: ! 369: .word 0 ! 370: Profile ! 371: movl -4(r6),r1 # put indicator in r1 ! 372: movl -8(r6),r0 # and atom into r0 ! 373: jeql nilpli # jump if atom is nil ! 374: shar $9,r0,r2 # check type ! 375: cmpb _typetable+1[r2],$1 # is it a symbol?? ! 376: jneq notsymb # nope ! 377: movl 4(r0),r0 # yes, put prop list in r1 to begin scan ! 378: jeql fail # if no prop list, we lose right away ! 379: lp: cmpl r1,4(r0) # is car of list eq to indicator? ! 380: jeql good # jump if so ! 381: movl *(r0),r0 # else cddr down list ! 382: jneq lp # and jump if more list to go. ! 383: ! 384: fail: subl2 $8,NP # unstack args ! 385: ret # return with r0 eq to nil ! 386: ! 387: good: movl (r0),r0 # return cadr of list ! 388: movl 4(r0),r0 ! 389: subl2 $8,NP #unstack args ! 390: ret ! 391: ! 392: nilpli: movl _lispsys+64*4,r0 # want nil prop list, get it specially ! 393: jneq lp # and process if anything there ! 394: subl2 $8,NP #unstack args ! 395: ret # else fail ! 396: ! 397: notsymb: ! 398: #ifdef PORTABLE ! 399: movl r6,NP ! 400: movab -8(r6),LBOT # must set up LBOT before calling ! 401: #else ! 402: movab -8(r6),LBOT # must set up LBOT before calling ! 403: #endif ! 404: callf $4,_Lget # not a symbol, call C routine to error check ! 405: subl2 $8,NP #unstack args ! 406: ret # and return what it returned. ! 407: ! 408: #ifdef NOTNOW ! 409: /* ! 410: * _qexarith exact arithmetic ! 411: * calculates x=a*b+c where a,b and c are 32 bit 2's complement integers ! 412: * whose top two bits must be the same (i.e. the are members of the set ! 413: * of valid fixnum values for Franz Lisp). The result, x, will be 64 bits ! 414: * long but since each of a, b and c had only 31 bits of precision, the ! 415: * result x only has 62 bits of precision. The lower 30 bits are returned ! 416: * in *plo and the high 32 bits are returned in *phi. If *phi is 0 or -1 then ! 417: * x doesn't need any more than 31 bits plus sign to describe, so we ! 418: * place the sign in the high two bits of *plo and return 0 from this ! 419: * routine. A non zero return indicates that x requires more than 31 bits ! 420: * to describe. ! 421: */ ! 422: ! 423: .globl _qexarith ! 424: /* qexarith(a,b,c,phi,plo) ! 425: * int *phi, *plo; ! 426: */ ! 427: _qexarith: ! 428: emul 4(sp),8(sp),12(sp),r2 #r2 = a*b + c to 64 bits ! 429: extzv $0,$30,r2,*20(sp) #get new lo ! 430: extv $30,$32,r2,r0 #get new carry ! 431: beql out # hi = 0, no work necessary ! 432: movl r0,*16(sp) # save hi ! 433: mcoml r0,r0 # Is hi = -1 (it'll fit in one word) ! 434: bneq out # it doesn't ! 435: bitl $0xc0000000,*20(sp) # alter low so that it is ok. ! 436: out: ret ! 437: ! 438: #endif ! 439: ! 440: #ifdef NOTNOW ! 441: /* ! 442: * pushframe : stack a frame ! 443: * When this is called, the optional arguments and class have already been ! 444: * pushed on the stack as well as the return address (by virtue of the jsb) ! 445: * , we push on the rest of the stuff (see h/frame.h) ! 446: * for a picture of the save frame ! 447: */ ! 448: .globl _qpushframe ! 449: ! 450: _qpushframe: ! 451: Profile ! 452: movl _errp,-(sp) ! 453: movl _bnp,-(sp) ! 454: movl NP,-(sp) ! 455: movl LBOT,-(sp) ! 456: storer $0x3f00, -(sp) # save r13(fp), r12(ap),r11,r10,r9,r8 ! 457: movab 6*4(sp),r0 # return addr of lbot on stack ! 458: clrl _retval # set retval to C_INITIAL ! 459: #ifndef SPISFP ! 460: jmp *40(sp) # return through return address ! 461: #else ! 462: movab -4(sp),sp ! 463: movl sp,(sp) ! 464: movl _xsp,-(sp) ! 465: jmp *48(sp) ! 466: #endif ! 467: ! 468: /* ! 469: * qretfromfr ! 470: * called with frame to ret to in r11. The popnames has already been done. ! 471: * we must restore all registers, and jump to the ret addr. the popping ! 472: * must be done without reducing the stack pointer since an interrupt ! 473: * could come in at any time and this frame must remain on the stack. ! 474: * thus we can't use popr. ! 475: */ ! 476: ! 477: .globl _qretfromfr ! 478: ! 479: _qretfromfr: ! 480: Profile ! 481: movl r11,r0 # return error frame location ! 482: subl3 $24,r11,sp # set up sp at bottom of frame ! 483: movl sp,r1 # prepare to pop off ! 484: movl (r0),r8 # was movd (r0)+, r8 and such ! 485: movl 4(r0),r9 ! 486: movl 8(r0),r10 ! 487: movl 12(r0),r11 ! 488: movl 16(r0),r12 ! 489: movl 20(r0),r13 ! 490: movl 24(r0),LBOT ! 491: movl 28(r0),NP ! 492: addl2 $32, r0 #just in case ! 493: jmp *40(sp) # jump out of frame ! 494: #endif NOTNOW ! 495: ! 496: #ifdef SPISFP ! 497: ! 498: /* ! 499: * this is equivalent to qretfro for a native VMS system ! 500: * ! 501: */ ! 502: .globl _Iretfrm ! 503: _Iretfrm: ! 504: .word 0 ! 505: movl 4(fp),r0 # return error frame location ! 506: movl r0,r1 ! 507: movd -(r1),r12 ! 508: movd -(r1),r10 ! 509: movd -(r1),r8 ! 510: movl -(r1),sp ! 511: movl -(r1),_xsp ! 512: movd -(r1),r6 ! 513: movd -(r1),r4 ! 514: movd -(r1),r2 ! 515: movl r0,r1 ! 516: movl (r1)+,LBOT ! 517: movl (r1)+,NP ! 518: jmp *16(r0) ! 519: #endif SPISPF ! 520: ! 521: /* ! 522: * this routine finishes setting things up for dothunk ! 523: * it is code shared to keep the size of c-callable thunks ! 524: * for lisp functions, small. ! 525: */ ! 526: .globl _thcpy ! 527: _thcpy: ! 528: movl (sp),r0 ! 529: pushl r12 ! 530: pushl (r0) ! 531: pushl 4(r0) ! 532: addl2 $8,r0 # was postincrement ! 533: callf $4,_dothunk ! 534: ret ! 535: /* ! 536: * This routine gets the name of the inital entry point ! 537: * It is here so it can be under ifdef control. ! 538: */ ! 539: .globl _gstart ! 540: _gstart: ! 541: .word 0 ! 542: #if os_vms ! 543: moval _$$$start,r0 ! 544: #else ! 545: moval start,r0 ! 546: #endif ! 547: ret ! 548: ! 549: .globl _proflush ! 550: _proflush: ! 551: .word 0 ! 552: ret ! 553: ! 554: /* ! 555: * The definition of mcount must be present even when the C code ! 556: * isn't being profiled, since lisp code may reference it. ! 557: */ ! 558: ! 559: #ifndef os_vms ! 560: .globl mcount ! 561: mcount: ! 562: #endif ! 563: ! 564: .globl _mcount ! 565: _mcount: ! 566: ! 567: #ifdef PROF ! 568: movl (r0),r1 ! 569: bneq incr ! 570: movl _countbase,r1 ! 571: beql return ! 572: addl2 $8,_countbase ! 573: movl (sp),(r1)+ ! 574: movl r1,(r0) ! 575: incr: ! 576: incl (r1) ! 577: return: ! 578: #endif ! 579: ret ! 580: ! 581: ! 582: /* This must be at the end of the file. If we are profiling, allocate ! 583: * space for the profile buffer ! 584: */ ! 585: #ifdef PROF ! 586: .data ! 587: .comm _countbase,4 ! 588: .lcomm prbuf,indx+4 ! 589: .text ! 590: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.