4.3BSD - /usr/src/ucb/lisp/franz/vax/qfuncl.c

   1:   .asciz "$Header: qfuncl.c,v 1.10 84/02/29 16:44:30 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: /*
 540:  * this routine finishes setting things up for dothunk
 541:  * it is code shared to keep the size of c-callable thunks
 542:  * for lisp functions, small.
 543:  */
 544:     .globl  _thcpy
 545: _thcpy:
 546:     movl    (sp),r0
 547:     pushl   ap
 548:     pushl   (r0)+
 549:     pushl   (r0)+
 550:     calls   $4,_dothunk
 551:     ret
 552: /*
 553:  * This routine gets the name of the inital entry point
 554:  * It is here so it can be under ifdef control.
 555:  */
 556:     .globl  _gstart
 557: _gstart:
 558:     .word   0
 559: #if os_vms
 560:     moval   _$$$start,r0
 561: #else
 562:     moval   start,r0
 563: #endif
 564:     ret
 565:     .globl  _proflush
 566: _proflush:
 567:     .word   0
 568:     ret
 569: 
 570: /*
 571:  * The definition of mcount must be present even when the C code
 572:  * isn't being profiled, since lisp code may reference it.
 573:  */
 574: 
 575: #ifndef os_vms
 576: .globl  mcount
 577: mcount:
 578: #endif
 579: 
 580: .globl _mcount
 581: _mcount:
 582: 
 583: #ifdef PROF
 584:     movl    (r0),r1
 585:     bneq    incr
 586:     movl    _countbase,r1
 587:     beql    return
 588:     addl2   $8,_countbase
 589:     movl    (sp),(r1)+
 590:     movl    r1,(r0)
 591: incr:
 592:     incl    (r1)
 593: return:
 594: #endif
 595:     rsb
 596: 
 597: 
 598: /* This must be at the end of the file.  If we are profiling, allocate
 599:  * space for the profile buffer
 600:  */
 601: #ifdef PROF
 602:     .data
 603:     .comm   _countbase,4
 604:     .lcomm  prbuf,indx+4
 605:     .text
 606: #endif

Defined functions

Defined macros