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