![[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 / 68k|
Return to qfuncl.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz / 68k |
1.1 ! root 1: /* ! 2: *$Header: qfuncl.c,v 1.7 83/09/06 21:49:27 layer Exp $ ! 3: *$Locker: $ ! 4: * ! 5: * Copyright (c) 1982, by the Regents, University of California ! 6: * ! 7: * -[Tue Mar 22 15:42:27 1983 by layer]- ! 8: * ! 9: * "quick" functions file. ! 10: * ! 11: * This is written in assembler but must be passed through the C preprocessor ! 12: * before being assembled. ! 13: * ! 14: */ ! 15: ! 16: #include "ltypes.h" ! 17: #include "config.h" ! 18: ! 19: /* important offsets within data types for atoms */ ! 20: #define Atomfnbnd 8 ! 21: ! 22: /* for arrays */ ! 23: #define Arrayaccfun 0 ! 24: ! 25: /* register defines */ ! 26: #define FIXREG d2 ! 27: ! 28: #ifdef NPINREG ! 29: #define _np a2 ! 30: #define _lbot d3 ! 31: #endif ! 32: ! 33: ! 34: #ifdef PROF ! 35: .set indx,0 ! 36: #define Profile \ ! 37: lea prbuf+indx,a0 \ ! 38: .set indx,indx+4 \ ! 39: jsr mcount ! 40: #define Profile2 \ ! 41: movl a0,sp@- ! 42: lea prbuf+indx,a0 \ ! 43: .set indx,indx+4 \ ! 44: jsr mcount ! 45: movl sp@+,a0 ! 46: #else ! 47: #define Profile ! 48: #define Profile2 ! 49: #endif ! 50: ! 51: #ifdef PORTABLE ! 52: #define NILtest(p) cmpl #/**/OFFSET,p ! 53: #define NILsub(p) subl #/**/OFFSET,p ! 54: #else ! 55: #define NILtest(p) ! 56: #define NILsub(p) ! 57: #endif ! 58: ! 59: ! 60: .text ! 61: ! 62: /* transfer table linkage routine */ ! 63: .globl _qlinker ! 64: _qlinker: ! 65: Profile ! 66: link a6,#-28 ! 67: tstb sp@(-132) ! 68: moveml #036000,a6@(-28) |a(2,3,4,5) ! 69: ! 70: tstl _exception |any pending exceptions ! 71: jeq noexc ! 72: tstl _sigintcnt |is it because of SIGINT ! 73: jeq noexc |if not, just leave ! 74: movl #2,sp@- |else push SIGINT ! 75: jsr _sigcall ! 76: noexc: ! 77: movl a6@(4),a4 |get return pc ! 78: movl a4@(-6),a4 |get pointer to table ! 79: movl a4@(4),a5 |get atom pointer ! 80: retry: |come here after undeffunc err ! 81: movl a5@(8),a0 |get function binding ! 82: cmpl a0,d7 |if nil, ! 83: jeq nonex |then leave ! 84: tstl 2*4+_stattab |see if linkin posble (Strans) ! 85: jeq nolink |no, it isn't ! 86: movl a0,d0 |check type of function ! 87: NILsub(d0) ! 88: moveq #9,d1 ! 89: asrl d1,d0 ! 90: lea _typetable+1,a3 ! 91: movb a3@(0,d0:L),d1 ! 92: cmpb #/**/BCD,d1 ! 93: jeq linkin |bcd, link it in! ! 94: cmpb #/**/ARRAY,d1 |how about array? ! 95: jeq doarray |yep ! 96: ! 97: nolink: ! 98: movl a5,sp@- |non, bcd, call interpreter ! 99: jsr _Ifuncal ! 100: moveml a6@(-28),#036000 ! 101: unlk a6 ! 102: rts ! 103: ! 104: /* ! 105: * handle arrays by pushing the array descriptor on the table and checking ! 106: * for a bcd array handler ! 107: */ ! 108: doarray: ! 109: movl a0@(Arrayaccfun),d0 |get access func addr shifted ! 110: NILsub(d0) ! 111: movl #9,d1 ! 112: asrl d1,d0 ! 113: lea _typetable+1,a3 ! 114: cmpb #/**/BCD,a3@(0,d0:L) |bcd?? ! 115: jne nolink |no, let funcal handle it ! 116: movl a0,a2@+ |store array header on stack ! 117: movl a2,_np ! 118: movl a0@,a0 |movl *(a0),a0 on VAX ! 119: movl a0@,a0 ! 120: jsr a0@ ! 121: subql #4,_np ! 122: moveml a6@(-28),#036000 ! 123: unlk a6 ! 124: rts ! 125: ! 126: ! 127: linkin: ! 128: movl a0@(4),d0 |check type of function discipline ! 129: NILsub(d0) ! 130: movl #9,d1 ! 131: asrl d1,d0 ! 132: lea _typetable+1,a3 ! 133: cmpb #/**/STRNG,a3@(0,d0:L) |is it string? ! 134: jeq nolink |yes, it is a c call, ! 135: |so dont link in ! 136: movl a0@,a0 |get function addr ! 137: movl a0,a4@ |put fcn addr in table ! 138: jbsr a0@ ! 139: moveml a6@(-28),#036000 ! 140: unlk a6 ! 141: rts ! 142: ! 143: ! 144: nonex: movl a4,sp@- |preserve table address ! 145: movl a5,sp@- |non existant fcn ! 146: jsr _Undeff |call processor ! 147: movl d0,a5 |back in r1 ! 148: addql #4,sp ! 149: movl sp@+,a4 |restore table address ! 150: jra retry |for the retry. ! 151: ! 152: ! 153: .data ! 154: .globl __erthrow ! 155: __erthrow: ! 156: .asciz "Uncaught throw from compiled code" ! 157: .text ! 158: ! 159: .globl _tynames ! 160: _tynames: ! 161: .long _nilatom |nothing here ! 162: .long 20*4+_lispsys |str_name ! 163: .long 21*4+_lispsys |atom_name ! 164: .long 19*4+_lispsys |int_name ! 165: .long 23*4+_lispsys |dtpr_name ! 166: .long 22*4+_lispsys |doub_name ! 167: .long 58*4+_lispsys |funct_name ! 168: .long 103*4+_lispsys |port_name ! 169: .long 47*4+_lispsys |array_name ! 170: .long _nilatom |nothing here ! 171: .long 50*4+_lispsys |sdot_name ! 172: .long 53*4+_lispsys |val_nam ! 173: ! 174: .long _nilatom | hunk2_nam ! 175: .long _nilatom | hunk4_nam ! 176: .long _nilatom | hunk8_nam ! 177: .long _nilatom | hunk16_nam ! 178: .long _nilatom | hunk32_nam ! 179: .long _nilatom | hunk64_nam ! 180: .long _nilatom | hunk128_nam ! 181: .long 124*4+_lispsys |vector_nam ! 182: .long 125*4+_lispsys |vectori_nam ! 183: ! 184: /* Quickly allocate small fixnums */ ! 185: ! 186: .globl _qnewint ! 187: _qnewint: ! 188: Profile ! 189: cmpl #1024,FIXREG ! 190: bge alloc ! 191: cmpl #-1024,FIXREG ! 192: bmi alloc ! 193: movl FIXREG,d0 ! 194: asll #2,d0 ! 195: addl #_Fixzero,d0 ! 196: rts ! 197: alloc: ! 198: movl _int_str,a0 |move next cell addr to r0 ! 199: NILtest(a0) ! 200: jmi callnewi |if no space, allocate ! 201: movl 4*24+_lispsys,a1 ! 202: addql #1,a1@ |inc count of ints ! 203: movl a0@,_int_str |advance free list ! 204: movl FIXREG,a0@ |put baby to bed. ! 205: movl a0,d0 ! 206: rts ! 207: callnewi: ! 208: movl FIXREG,sp@- ! 209: movl a2,_np |gc could occur ! 210: movl a2,_lbot ! 211: jsr _newint ! 212: movl d0,a0 ! 213: movl sp@+,a0@ ! 214: rts ! 215: ! 216: /* _qoneplus adds one to the boxed fixnum in r0 ! 217: * and returns a boxed fixnum. ! 218: */ ! 219: ! 220: .globl _qoneplus ! 221: _qoneplus: ! 222: Profile ! 223: movl a0@,FIXREG ! 224: addql #1,FIXREG ! 225: bra _qnewint ! 226: ! 227: /* _qoneminus subtracts one from the boxes fixnum in r0 and returns a ! 228: * boxed fixnum ! 229: */ ! 230: .globl _qoneminus ! 231: _qoneminus: ! 232: Profile ! 233: movl a0@,FIXREG ! 234: subql #1,FIXREG ! 235: bra _qnewint ! 236: ! 237: /* ! 238: * _qnewdoub quick allocation of a initialized double (float) cell. ! 239: * This entry point is required by the compiler for symmetry reasons. ! 240: * Passed to _qnewdoub in d0,d1 is a double precision floating point ! 241: * number. This routine allocates a new cell, initializes it with ! 242: * the given value and then returns the cell. ! 243: */ ! 244: ! 245: .globl _qnewdoub ! 246: ! 247: _qnewdoub: ! 248: Profile ! 249: movl _doub_str,a0 |move next cell addr to r0 ! 250: NILtest(a0) ! 251: jmi callnewd |if no space, allocate ! 252: |incl *_lispsys+30*4 |inc count of doubs ! 253: lea 30*4+_lispsys,a1 ! 254: addl #1,a1@ ! 255: movl a0@,_doub_str |advance free list ! 256: strdb: ! 257: movl d0,a0@ |put baby to bed. ! 258: movl d1,a0@(4) |put baby to bed. ! 259: rts ! 260: ! 261: callnewd: ! 262: movl d0,sp@- |stack initial value ! 263: movl d1,sp@- |stack initial value ! 264: movl a2,_np |gc could occur ! 265: movl a2,_lbot ! 266: jsr _newdoub ! 267: movl d0,a0 ! 268: movl sp@+,d1 |restore initial value ! 269: movl sp@+,d0 |restore initial value ! 270: bra strdb ! 271: ! 272: ! 273: ! 274: /* ! 275: * quick cons call, the car and cdr are stacked on the namestack ! 276: * and this function is jsb'ed to. ! 277: */ ! 278: .globl _qcons ! 279: _qcons: ! 280: Profile ! 281: movl _dtpr_str,a0 |move next cell addr to a0 ! 282: NILtest(a0) ! 283: jmi getnew |if ran out of space jump ! 284: movl 28*4+_lispsys,a1 |inc count of dtprs ! 285: addql #1,a1@ ! 286: movl a0@,_dtpr_str |advance free list ! 287: storit: movl a2@-,a0@ |store in cdr ! 288: movl a2@-,a0@(4) |store in car ! 289: movl a0,d0 ! 290: rts ! 291: ! 292: getnew: movl a2,_np ! 293: jsr _newdot |must gc to get one ! 294: jra storit |now initialize it. ! 295: ! 296: /* ! 297: * Fast equivalent of newdot, entered by jsb ! 298: */ ! 299: ! 300: .globl _qnewdot ! 301: _qnewdot: ! 302: Profile ! 303: movl _dtpr_str,a0 |mov next cell addr t0 r0 ! 304: NILtest(a0) ! 305: jmi mustallo |if ran out of space ! 306: ! 307: movl a0,sp@- ! 308: movl 28*4+_lispsys,a0 |inc count of dtprs ! 309: addql #1,a0@ ! 310: movl sp@+,a0 ! 311: ! 312: movl a0@,_dtpr_str |advance free list ! 313: clrl a0@ |clrq (r0) ! 314: clrl a0@(4) ! 315: rts ! 316: mustallo: ! 317: movl a2,_np |gc could occur ! 318: jsr _newdot ! 319: rts ! 320: ! 321: ! 322: /* ! 323: * this is called exactly like popnames would be from C ! 324: * but has been carefully improved so that it doesn't ! 325: * have to alter the stack. ! 326: */ ! 327: .globl _qpopnames ! 328: _qpopnames: ! 329: movl _bnp,a1 ! 330: movl sp,a0 ! 331: movl a0@(4),d0 ! 332: jra .L130 ! 333: .L20001: ! 334: movl a1@(4),a0 ! 335: movl a1@,a0@ ! 336: .L130: ! 337: subql #8,a1 ! 338: cmpl a1,d0 ! 339: jls .L20001 ! 340: movl a1,_bnp ! 341: rts ! 342: ! 343: /* ! 344: * _qget : fast get subroutine ! 345: * (get 'atom 'ind) ! 346: * called with a2@(-8) equal to the atom ! 347: * a2@(-4) 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 a2@(-4),a1 |put indicator in a1 ! 360: movl a2@(-8),a0 |and atom into a0 ! 361: cmpl a0,d7 ! 362: jeq nilpli |jump if atom is nil ! 363: movl a0,d0 |check type ! 364: NILsub(d0) ! 365: movl #9,d1 ! 366: asrl d1,d0 ! 367: lea _typetable+1,a5 ! 368: cmpb #/**/ATOM,a5@(0,d0:L) |is it a symbol?? ! 369: jne notsymb |nope ! 370: movl a0@(4),a0 |yes, put prop list in ! 371: | a0 to begin scan ! 372: cmpl a0,d7 ! 373: jeq fail |if no prop list, ! 374: | we lose right away ! 375: lp: cmpl a0@(4),a1 |is car of list = to indicator? ! 376: jeq good |jump if so ! 377: movl a0@,a0 |else cddr ! 378: movl a0@,a0 | down list ! 379: cmpl a0,d7 ! 380: jne lp |and jump if more list to go. ! 381: ! 382: fail: movl a0,d0 ! 383: subql #8,a2 ! 384: rts |return with a0 eq to nil ! 385: ! 386: good: movl a0@,a0 |return cadr of list ! 387: movl a0@(4),d0 ! 388: subql #8,a2 ! 389: rts ! 390: ! 391: nilpli: movl 64*4+_lispsys,a0 |want nil prop list, ! 392: | get it specially ! 393: cmpl a0,d7 ! 394: jne lp |and process if anything there ! 395: movl a0,d0 ! 396: subql #8,a2 ! 397: rts |else fail ! 398: ! 399: notsymb: ! 400: lea a2@(-8),a0 |set up lbot before callin ! 401: movl a0,_lbot ! 402: movl a2,_np ! 403: jsr _Lget |not a symbol, call C routine ! 404: | to error check ! 405: subql #8,a2 ! 406: rts |and return what it returned. ! 407: ! 408: ! 409: /* ! 410: * prunel - return a list of dtpr cells to the free list ! 411: * this is called by the pruneb after it has discarded the top bignum ! 412: * the dtpr cells are linked through their cars not their cdrs. ! 413: * this returns with an rsb ! 414: * ! 415: * method of operation: the dtpr list we get is linked by car's so we ! 416: * go through the list and link it by cdr's, then have the last dtpr ! 417: * point to the free list and then make the free list begin at the ! 418: * first dtpr. ! 419: */ ! 420: qprunel: ! 421: movl a0,d0 |remember first dtpr location ! 422: movl 28*4+_lispsys,a1 |dec count of dtprs ! 423: rep: ! 424: subql #1,a2@ ! 425: movl a0@(4),a0@ |make cdr (forward lnk) == car ! 426: jeq endoflist |if nil, then end of list ! 427: movl a0@,a0 |advance to next dtpr ! 428: jra rep |and loop around ! 429: endoflist: ! 430: movl _dtpr_str,a0@ |make last 1 pnt to free list ! 431: movl d0,_dtpr_str |& free list begin at 1st one ! 432: rts ! 433: ! 434: /* ! 435: * qpruneb - called by the arithmetic routines to free an sdot and the dtprs ! 436: * which hang on it. ! 437: * called by ! 438: * pushl sdotaddr ! 439: * jsb _qpruneb ! 440: */ ! 441: .globl _qpruneb ! 442: _qpruneb: ! 443: Profile ! 444: movl 48*4+_lispsys,a0 |decr count of used sdots ! 445: subql #1,a0@ ! 446: movl sp@(4),a0 |get address ! 447: movl _sdot_str,a0@ |have new sdot pnt to free lst ! 448: movl a0,_sdot_str |strt free list at new sdot ! 449: movl a0@(4),a0 |get address of first dtpr ! 450: jne qprunel |if exists, prune it ! 451: rts |else return. ! 452: ! 453: ! 454: /* ! 455: * _qprunei ! 456: * called by the arithmetic routines to free a fixnum cell ! 457: * calling sequence ! 458: * pushl fixnumaddr ! 459: * jsb _qprunei ! 460: */ ! 461: ! 462: .globl _qprunei ! 463: _qprunei: ! 464: Profile ! 465: movl a1,sp@- ! 466: movl sp@(4),a0 |get address of fixnum ! 467: cmpl #4*1023+_Fixzero,a0 |is it a small fixnum ! 468: jmi skipit |if so, leave ! 469: movl 24*4+_lispsys,a1 |decr count of used ints ! 470: subql #1,a1@ ! 471: movl _int_str,a0@ |link the fixnum into the ! 472: | free list ! 473: movl a0,_int_str ! 474: skipit: ! 475: movl sp@+,a1 ! 476: rts ! 477: Iclear: ! 478: clrl d0 ! 479: rts ! 480: .text ! 481: .globl _Itstbt ! 482: _Itstbt: ! 483: movl a5,d1 ! 484: NILsub(d1) ! 485: lsrl #2,d1 ! 486: movl d1,d0 ! 487: andl #7,d0 ! 488: lsrl #3,d1 ! 489: lea _bitmapi,a0 ! 490: bset d0,a0@(0,d1:L) ! 491: beq .L14 ! 492: moveq #1,d0 ! 493: bra .L12 ! 494: .L14: ! 495: clrl d0 ! 496: .L12: rts ! 497: ! 498: /* ! 499: * this routine returns an assembly language entry pt. ! 500: * it is put here to match the vax verison. ! 501: */ ! 502: .globl _gstart ! 503: .globl _proflush ! 504: _gstart: ! 505: movl #start,d0 ! 506: _proflush: ! 507: rts ! 508: /* ! 509: * The definition of mcount must be present even when the C code ! 510: * isn't being profiled, since lisp code may reference it. ! 511: */ ! 512: .globl _mcount ! 513: #ifdef SunGotItsActTogetherAboutTakingMcountOutOfCrt0 ! 514: .globl mcount ! 515: #endif ! 516: ! 517: _mcount: ! 518: mcount: ! 519: #ifdef PROF ! 520: movl a0@,a1 ! 521: jne incr ! 522: movl _countbase,a1 ! 523: jeq return ! 524: addql #8,_countbase ! 525: movl sp@,a1@+ ! 526: movl a1,a0@ ! 527: incr: ! 528: addql #1,a1@ ! 529: return: ! 530: #endif ! 531: rts ! 532: ! 533: /* ! 534: * pushframe : stack a frame ! 535: * When this is called, the optional arguments and class have already been ! 536: * pushed on the stack as well as the return address (by virtue of the jsb) ! 537: * , we push on the rest of the stuff (see h/frame.h) ! 538: * for a picture of the save frame ! 539: */ ! 540: .globl _pushframe ! 541: .globl _qpushframe ! 542: .globl _Pushframe ! 543: _pushframe: ! 544: _qpushframe: ! 545: _Pushframe: ! 546: movl sp@,a0 ! 547: movl _errp,sp@- ! 548: movl _bnp,sp@- ! 549: movl _np,sp@- ! 550: movl _lbot,sp@- ! 551: movl sp,d0 | return addr of lbot on stack ! 552: subl #56,sp ! 553: moveml #0x7cfc,sp@(12) | save fp,a5-a2,d7-d2 ! 554: clrl _retval | set retval to C_INITIAL ! 555: jmp a0@ | return through return address ! 556: ! 557: /* ! 558: * qretfromfr ! 559: * called with frame to ret to in a5. The popnames has already been done. ! 560: * we must restore all registers, and jump to the ret addr. the popping ! 561: * must be done without reducing the stack pointer since an interrupt ! 562: * could come in at any time and this frame must remain on the stack. ! 563: * thus we can't use popr. ! 564: */ ! 565: ! 566: .globl _qretfromfr ! 567: ! 568: _qretfromfr: ! 569: movl a5,d0 | return error frame location ! 570: movl a5,a0 | prepare to pop off ! 571: moveml a0@(-44),#0x7cfc | restore registers ! 572: lea a0@(-56),sp ! 573: movl a0@+,_lbot ! 574: movl a0@+,_np ! 575: movl a0@(8),a0 | return address ! 576: jmp a0@ ! 577: ! 578: /* This must be at the end of the file. If we are profiling, allocate ! 579: * space for the profile buffer ! 580: */ ! 581: #ifdef PROF ! 582: .data ! 583: .comm _countbase,4 ! 584: .lcomm prbuf,indx+4 ! 585: .text ! 586: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.