From a536940118054fd0576f1bddc1c8c206d4509e7b Mon Sep 17 00:00:00 2001 From: CSRG Date: Wed, 29 Feb 1984 01:45:21 -0800 Subject: [PATCH] BSD 4_3_Tahoe development Work on file usr/tmp/housel/franz/vax/qfuncl.c Work on file usr/src/ucb/lisp/franz/vax/qfuncl.c Synthesized-from: CSRG/cd2/4.3tahoe --- usr/src/ucb/lisp/franz/vax/qfuncl.c | 606 ++++++++++++++++++++++++++++ usr/tmp/housel/franz/vax/qfuncl.c | 606 ++++++++++++++++++++++++++++ 2 files changed, 1212 insertions(+) create mode 100644 usr/src/ucb/lisp/franz/vax/qfuncl.c create mode 100644 usr/tmp/housel/franz/vax/qfuncl.c diff --git a/usr/src/ucb/lisp/franz/vax/qfuncl.c b/usr/src/ucb/lisp/franz/vax/qfuncl.c new file mode 100644 index 0000000000..6b40e7a0dc --- /dev/null +++ b/usr/src/ucb/lisp/franz/vax/qfuncl.c @@ -0,0 +1,606 @@ + .asciz "$Header: qfuncl.c,v 1.10 84/02/29 16:44:30 sklower Exp $" + +/* -[Mon Mar 21 17:04:58 1983 by jkf]- + * qfuncl.c $Locker: $ + * lisp to C interface + * + * (c) copyright 1982, Regents of the University of California + */ + +/* + * This is written in assembler but must be passed through the C preprocessor + * before being assembled. + */ + +#include "ltypes.h" +#include "config.h" + +/* important offsets within data types for atoms */ +#define Atomfnbnd 8 + +/* for arrays */ +#define Arrayaccfun 0 + +#ifdef PROF + .set indx,0 +#define Profile \ + movab prbuf+indx,r0 \ + .set indx,indx+4 \ + jsb mcount +#define Profile2 \ + movl r0,r5 \ + Profile \ + movl r5,r0 +#else +#define Profile +#define Profile2 +#endif + +#ifdef PORTABLE +#define NIL _nilatom +#define NP _np +#define LBOT _lbot +#else +#define NIL 0 +#define NP r6 +#define LBOT r7 +#endif + + +/* transfer table linkage routine */ + + .globl _qlinker +_qlinker: + .word 0xfc0 # save all possible registers + Profile + tstl _exception # any pending exceptions + jeql noexc + tstl _sigintcnt # is it because of SIGINT + jeql noexc # if not, just leave + pushl $2 # else push SIGINT + calls $1,_sigcall +noexc: + movl 16(fp),r0 # get return pc + addl2 -4(r0),r0 # get pointer to table + movl 4(r0),r1 # get atom pointer +retry: # come here after undef func error + movl Atomfnbnd(r1),r2 # get function binding + jleq nonex # if none, leave + tstl _stattab+2*4 # see if linking possible (Strans) + jeql nolink # no, it isn't + ashl $-9,r2,r3 # check type of function + cmpb $/**/BCD,_typetable+1[r3] + jeql linkin # bcd, link it in! + cmpb $/**/ARRAY,_typetable+1[r3] # how about array? + jeql doarray # yep + + +nolink: + pushl r1 # non, bcd, call interpreter + calls $1,_Ifuncal + ret + +/* + * handle arrays by pushing the array descriptor on the table and checking + * for a bcd array handler + */ +doarray: + ashl $-9,Arrayaccfun(r2),r3 # get access function addr shifted + cmpb $/**/BCD,_typetable+1[r3] # bcd?? + jneq nolink # no, let funcal handle it +#ifdef PORTABLE + movl NP,r4 + movl r2,(r4)+ # store array header on stack + movl r4,NP +#else + movl r2,(r6)+ # store array header on stack +#endif + movl *(r2),r2 # get in func addr + jmp 2(r2) # jump in beyond calls header + + +linkin: + ashl $-9,4(r2),r3 # check type of function discipline + cmpb $0,_typetable+1[r3] # is it string? + jeql nolink # yes, it is a c call, so dont link in + movl (r2),r2 # get function addr + movl r2,(r0) # put fcn addr in table + jmp 2(r2) # enter fcn after mask + +nonex: pushl r0 # preserve table address + pushl r1 # non existant fcn + calls $1,_Undeff # call processor + movl r0,r1 # back in r1 + movl (sp)+,r0 # restore table address + jbr retry # for the retry. + + + .globl __erthrow # errmessage for uncaught throws +__erthrow: + .asciz "Uncaught throw from compiled code" + + .globl _tynames +_tynames: + .long NIL # nothing here + .long _lispsys+20*4 # str_name + .long _lispsys+21*4 # atom_name + .long _lispsys+19*4 # int_name + .long _lispsys+23*4 # dtpr_name + .long _lispsys+22*4 # doub_name + .long _lispsys+58*4 # funct_name + .long _lispsys+103*4 # port_name + .long _lispsys+47*4 # array_name + .long NIL # nothing here + .long _lispsys+50*4 # sdot_name + .long _lispsys+53*4 # val_nam + .long NIL # hunk2_nam + .long NIL # hunk4_nam + .long NIL # hunk8_nam + .long NIL # hunk16_nam + .long NIL # hunk32_nam + .long NIL # hunk64_nam + .long NIL # hunk128_nam + .long _lispsys+124*4 # vector_nam + .long _lispsys+125*4 # vectori_nam + +/* Quickly allocate small fixnums */ + + .globl _qnewint +_qnewint: + Profile + cmpl r5,$1024 + jgeq alloc + cmpl r5,$-1024 + jlss alloc + moval _Fixzero[r5],r0 + rsb +alloc: + movl _int_str,r0 # move next cell addr to r0 + jlss callnewi # if no space, allocate + incl *_lispsys+24*4 # inc count of ints + movl (r0),_int_str # advance free list + movl r5,(r0) # put baby to bed. + rsb +callnewi: + pushl r5 + calls $0,_newint + movl (sp)+,(r0) + rsb + + +/* _qoneplus adds one to the boxed fixnum in r0 + * and returns a boxed fixnum. + */ + + .globl _qoneplus +_qoneplus: + Profile2 + addl3 (r0),$1,r5 +#ifdef PORTABLE + movl r6,NP + movl r6,LBOT +#endif + jmp _qnewint + +/* _qoneminus subtracts one from the boxes fixnum in r0 and returns a + * boxed fixnum + */ + .globl _qoneminus +_qoneminus: + Profile2 + subl3 $1,(r0),r5 +#ifdef PORTABLE + movl r6,NP + movl r6,LBOT +#endif + jmp _qnewint + +/* + * _qnewdoub quick allocation of a initialized double (float) cell. + * This entry point is required by the compiler for symmetry reasons. + * Passed to _qnewdoub in r4,r5 is a double precision floating point + * number. This routine allocates a new cell, initializes it with + * the given value and then returns the cell. + */ + + .globl _qnewdoub +_qnewdoub: + Profile + movl _doub_str,r0 # move next cell addr to r0 + jlss callnewd # if no space, allocate + incl *_lispsys+30*4 # inc count of doubs + movl (r0),_doub_str # advance free list + movq r4,(r0) # put baby to bed. + rsb + +callnewd: + movq r4,-(sp) # stack initial value + calls $0,_newdoub + movq (sp)+,(r0) # restore initial value + rsb + + .globl _qcons + +/* + * quick cons call, the car and cdr are stacked on the namestack + * and this function is jsb'ed to. + */ + +_qcons: + Profile + movl _dtpr_str,r0 # move next cell addr to r0 + jlss getnew # if ran out of space jump + incl *_lispsys+28*4 # inc count of dtprs + movl (r0),_dtpr_str # advance free list +storit: + movl -(r6),(r0) # store in cdr + movl -(r6),4(r0) # store in car + rsb + +getnew: +#ifdef PORTABLE + movl r6,NP + movab -8(r6),LBOT +#endif + calls $0,_newdot # must gc to get one + jbr storit # now initialize it. + +/* + * Fast equivalent of newdot, entered by jsb + */ + + .globl _qnewdot +_qnewdot: + Profile + movl _dtpr_str,r0 # mov next cell addr t0 r0 + jlss mustallo # if ran out of space + incl *_lispsys+28*4 # inc count of dtprs + movl (r0),_dtpr_str # advance free list + clrq (r0) + rsb +mustallo: + calls $0,_newdot + rsb + +/* prunel - return a list of dtpr cells to the free list + * this is called by the pruneb after it has discarded the top bignum + * the dtpr cells are linked through their cars not their cdrs. + * this returns with an rsb + * + * method of operation: the dtpr list we get is linked by car's so we + * go through the list and link it by cdr's, then have the last dtpr + * point to the free list and then make the free list begin at the + * first dtpr. + */ +qprunel: + movl r0,r2 # remember first dtpr location +rep: decl *_lispsys+28*4 # decrement used dtpr count + movl 4(r0),r1 # put link value into r1 + jeql endoflist # if nil, then end of list + movl r1,(r0) # repl cdr w/ save val as car + movl r1,r0 # advance to next dtpr + jbr rep # and loop around +endoflist: + movl _dtpr_str,(r0) # make last 1 pnt to free list + movl r2,_dtpr_str # & free list begin at 1st 1 + rsb + +/* + * qpruneb - called by the arithmetic routines to free an sdot and the dtprs + * which hang on it. + * called by + * pushl sdotaddr + * jsb _qpruneb + */ + .globl _qpruneb +_qpruneb: + Profile + movl 4(sp),r0 # get address + decl *_lispsys+48*4 # decr count of used sdots + movl _sdot_str,(r0) # have new sdot point to free list + movl r0,_sdot_str # start free list at new sdot + movl 4(r0),r0 # get address of first dtpr + jneq qprunel # if exists, prune it + rsb # else return. + + +/* + * _qprunei + * called by the arithmetic routines to free a fixnum cell + * calling sequence + * pushl fixnumaddr + * jsb _qprunei + */ + + .globl _qprunei +_qprunei: + Profile + movl 4(sp),r0 # get address of fixnum + cmpl r0,$_Lastfix # is it a small fixnum + jleq skipit # if so, leave + decl *_lispsys+24*4 # decr count of used ints + movl _int_str,(r0) # link the fixnum into the free list + movl r0,_int_str +skipit: + rsb + + + .globl _qpopnames +_qpopnames: # equivalent of C-code popnames, entered by jsb. + movl (sp)+,r0 # return address + movl (sp)+,r1 # Lower limit + movl _bnp,r2 # pointer to bind stack entry +qploop: + subl2 $8,r2 # for(; (--r2) > r1;) { + cmpl r2,r1 # test for done + jlss qpdone + movl (r2),*4(r2) # r2->atm->a.clb = r2 -> val; + brb qploop # } +qpdone: + movl r1,_bnp # restore bnp + jmp (r0) # return + +/* + * _qget : fast get subroutine + * (get 'atom 'ind) + * called with -8(r6) equal to the atom + * -4(r6) equal to the indicator + * no assumption is made about LBOT + * unfortunately, the atom may not in fact be an atom, it may + * be a list or nil, which are special cases. + * For nil, we grab the nil property list (stored in a special place) + * and for lists we punt and call the C routine since it is most likely + * and error and we havent put in error checks yet. + */ + + .globl _qget +_qget: + Profile + movl -4(r6),r1 # put indicator in r1 + movl -8(r6),r0 # and atom into r0 + jeql nilpli # jump if atom is nil + ashl $-9,r0,r2 # check type + cmpb _typetable+1[r2],$1 # is it a symbol?? + jneq notsymb # nope + movl 4(r0),r0 # yes, put prop list in r1 to begin scan + jeql fail # if no prop list, we lose right away +lp: cmpl r1,4(r0) # is car of list eq to indicator? + jeql good # jump if so + movl *(r0),r0 # else cddr down list + jneq lp # and jump if more list to go. + +fail: subl2 $8,NP # unstack args + rsb # return with r0 eq to nil + +good: movl (r0),r0 # return cadr of list + movl 4(r0),r0 + subl2 $8,NP #unstack args + rsb + +nilpli: movl _lispsys+64*4,r0 # want nil prop list, get it specially + jneq lp # and process if anything there + subl2 $8,NP #unstack args + rsb # else fail + +notsymb: +#ifdef PORTABLE + movl r6,NP + movab -8(r6),LBOT # must set up LBOT before calling +#else + movab -8(r6),LBOT # must set up LBOT before calling +#endif + calls $0,_Lget # not a symbol, call C routine to error check + subl2 $8,NP #unstack args + rsb # and return what it returned. + +/* + * _qexarith exact arithmetic + * calculates x=a*b+c where a,b and c are 32 bit 2's complement integers + * whose top two bits must be the same (i.e. the are members of the set + * of valid fixnum values for Franz Lisp). The result, x, will be 64 bits + * long but since each of a, b and c had only 31 bits of precision, the + * result x only has 62 bits of precision. The lower 30 bits are returned + * in *plo and the high 32 bits are returned in *phi. If *phi is 0 or -1 then + * x doesn't need any more than 31 bits plus sign to describe, so we + * place the sign in the high two bits of *plo and return 0 from this + * routine. A non zero return indicates that x requires more than 31 bits + * to describe. + */ + + .globl _qexarith +/* qexarith(a,b,c,phi,plo) + * int *phi, *plo; + */ +_qexarith: + emul 4(sp),8(sp),12(sp),r2 #r2 = a*b + c to 64 bits + extzv $0,$30,r2,*20(sp) #get new lo + extv $30,$32,r2,r0 #get new carry + beql out # hi = 0, no work necessary + movl r0,*16(sp) # save hi + mcoml r0,r0 # Is hi = -1 (it'll fit in one word) + bneq out # it doesn't + bisl2 $0xc0000000,*20(sp) # alter low so that it is ok. +out: rsb + + + +/* + * pushframe : stack a frame + * When this is called, the optional arguments and class have already been + * pushed on the stack as well as the return address (by virtue of the jsb) + * , we push on the rest of the stuff (see h/frame.h) + * for a picture of the save frame + */ + .globl _qpushframe + +_qpushframe: + Profile + movl _errp,-(sp) + movl _bnp,-(sp) + movl NP,-(sp) + movl LBOT,-(sp) + pushr $0x3f00 # save r13(fp), r12(ap),r11,r10,r9,r8 + movab 6*4(sp),r0 # return addr of lbot on stack + clrl _retval # set retval to C_INITIAL +#ifndef SPISFP + jmp *40(sp) # return through return address +#else + movab -4(sp),sp + movl sp,(sp) + movl _xsp,-(sp) + jmp *48(sp) +#endif + +/* + * Ipushf : stack a frame, where space is preallocated on the stack. + * this is like pushframe, except that it doesn't alter the stack pointer + * and will save more registers. + * This might be written a little more quickly by having a bigger register + * save mask, but this is only supposed to be an example for the + * IBM and RIDGE people. + */ + +#ifdef SPISFP + .globl _Ipushf +_Ipushf: + .word 0 + addl3 $96,16(ap),r1 + movl 12(ap),-(r1) + movl 8(ap),-(r1) + movl 4(ap),-(r1) + movl 16(fp),-(r1) + movl _errp,-(r1) + movl _bnp,-(r1) + movl NP,-(r1) + movl LBOT,-(r1) + movl r1,r0 + movq 8(fp),-(r1) /* save stuff in the same order unix saves them + (r13,r12,r11,r10,r9,r8) and then add extra + for vms (sp,r7,r6,r5,r4,r3,r2) */ + movq r10,-(r1) + movq r8,-(r1) + movab 20(ap),-(r1) /* assumes Ipushf allways called by calls, with + the stack alligned */ + movl _xsp,-(r1) + movq r6,-(r1) + movq r4,-(r1) + movq r2,-(r1) + clrl _retval + ret +#endif +/* + * qretfromfr + * called with frame to ret to in r11. The popnames has already been done. + * we must restore all registers, and jump to the ret addr. the popping + * must be done without reducing the stack pointer since an interrupt + * could come in at any time and this frame must remain on the stack. + * thus we can't use popr. + */ + + .globl _qretfromfr + +_qretfromfr: + Profile + movl r11,r0 # return error frame location + subl3 $24,r11,sp # set up sp at bottom of frame + movl sp,r1 # prepare to pop off + movq (r1)+,r8 # r8,r9 + movq (r1)+,r10 # r10,r11 + movq (r1)+,r12 # r12,r13 + movl (r1)+,LBOT # LBOT (lbot) + movl (r1)+,NP # NP (np) + jmp *40(sp) # jump out of frame + +#ifdef SPISFP + +/* + * this is equivalent to qretfro for a native VMS system + * + */ + .globl _Iretfrm +_Iretfrm: + .word 0 + movl 4(ap),r0 # return error frame location + movl r0,r1 + movq -(r1),ap + movq -(r1),r10 + movq -(r1),r8 + movl -(r1),sp + movl -(r1),_xsp + movq -(r1),r6 + movq -(r1),r4 + movq -(r1),r2 + movl r0,r1 + movl (r1)+,LBOT + movl (r1)+,NP + jmp *16(r0) +#endif + +/* + * this routine finishes setting things up for dothunk + * it is code shared to keep the size of c-callable thunks + * for lisp functions, small. + */ + .globl _thcpy +_thcpy: + movl (sp),r0 + pushl ap + pushl (r0)+ + pushl (r0)+ + calls $4,_dothunk + ret +/* + * This routine gets the name of the inital entry point + * It is here so it can be under ifdef control. + */ + .globl _gstart +_gstart: + .word 0 +#if os_vms + moval _$$$start,r0 +#else + moval start,r0 +#endif + ret + .globl _proflush +_proflush: + .word 0 + ret + +/* + * The definition of mcount must be present even when the C code + * isn't being profiled, since lisp code may reference it. + */ + +#ifndef os_vms +.globl mcount +mcount: +#endif + +.globl _mcount +_mcount: + +#ifdef PROF + movl (r0),r1 + bneq incr + movl _countbase,r1 + beql return + addl2 $8,_countbase + movl (sp),(r1)+ + movl r1,(r0) +incr: + incl (r1) +return: +#endif + rsb + + +/* This must be at the end of the file. If we are profiling, allocate + * space for the profile buffer + */ +#ifdef PROF + .data + .comm _countbase,4 + .lcomm prbuf,indx+4 + .text +#endif diff --git a/usr/tmp/housel/franz/vax/qfuncl.c b/usr/tmp/housel/franz/vax/qfuncl.c new file mode 100644 index 0000000000..6b40e7a0dc --- /dev/null +++ b/usr/tmp/housel/franz/vax/qfuncl.c @@ -0,0 +1,606 @@ + .asciz "$Header: qfuncl.c,v 1.10 84/02/29 16:44:30 sklower Exp $" + +/* -[Mon Mar 21 17:04:58 1983 by jkf]- + * qfuncl.c $Locker: $ + * lisp to C interface + * + * (c) copyright 1982, Regents of the University of California + */ + +/* + * This is written in assembler but must be passed through the C preprocessor + * before being assembled. + */ + +#include "ltypes.h" +#include "config.h" + +/* important offsets within data types for atoms */ +#define Atomfnbnd 8 + +/* for arrays */ +#define Arrayaccfun 0 + +#ifdef PROF + .set indx,0 +#define Profile \ + movab prbuf+indx,r0 \ + .set indx,indx+4 \ + jsb mcount +#define Profile2 \ + movl r0,r5 \ + Profile \ + movl r5,r0 +#else +#define Profile +#define Profile2 +#endif + +#ifdef PORTABLE +#define NIL _nilatom +#define NP _np +#define LBOT _lbot +#else +#define NIL 0 +#define NP r6 +#define LBOT r7 +#endif + + +/* transfer table linkage routine */ + + .globl _qlinker +_qlinker: + .word 0xfc0 # save all possible registers + Profile + tstl _exception # any pending exceptions + jeql noexc + tstl _sigintcnt # is it because of SIGINT + jeql noexc # if not, just leave + pushl $2 # else push SIGINT + calls $1,_sigcall +noexc: + movl 16(fp),r0 # get return pc + addl2 -4(r0),r0 # get pointer to table + movl 4(r0),r1 # get atom pointer +retry: # come here after undef func error + movl Atomfnbnd(r1),r2 # get function binding + jleq nonex # if none, leave + tstl _stattab+2*4 # see if linking possible (Strans) + jeql nolink # no, it isn't + ashl $-9,r2,r3 # check type of function + cmpb $/**/BCD,_typetable+1[r3] + jeql linkin # bcd, link it in! + cmpb $/**/ARRAY,_typetable+1[r3] # how about array? + jeql doarray # yep + + +nolink: + pushl r1 # non, bcd, call interpreter + calls $1,_Ifuncal + ret + +/* + * handle arrays by pushing the array descriptor on the table and checking + * for a bcd array handler + */ +doarray: + ashl $-9,Arrayaccfun(r2),r3 # get access function addr shifted + cmpb $/**/BCD,_typetable+1[r3] # bcd?? + jneq nolink # no, let funcal handle it +#ifdef PORTABLE + movl NP,r4 + movl r2,(r4)+ # store array header on stack + movl r4,NP +#else + movl r2,(r6)+ # store array header on stack +#endif + movl *(r2),r2 # get in func addr + jmp 2(r2) # jump in beyond calls header + + +linkin: + ashl $-9,4(r2),r3 # check type of function discipline + cmpb $0,_typetable+1[r3] # is it string? + jeql nolink # yes, it is a c call, so dont link in + movl (r2),r2 # get function addr + movl r2,(r0) # put fcn addr in table + jmp 2(r2) # enter fcn after mask + +nonex: pushl r0 # preserve table address + pushl r1 # non existant fcn + calls $1,_Undeff # call processor + movl r0,r1 # back in r1 + movl (sp)+,r0 # restore table address + jbr retry # for the retry. + + + .globl __erthrow # errmessage for uncaught throws +__erthrow: + .asciz "Uncaught throw from compiled code" + + .globl _tynames +_tynames: + .long NIL # nothing here + .long _lispsys+20*4 # str_name + .long _lispsys+21*4 # atom_name + .long _lispsys+19*4 # int_name + .long _lispsys+23*4 # dtpr_name + .long _lispsys+22*4 # doub_name + .long _lispsys+58*4 # funct_name + .long _lispsys+103*4 # port_name + .long _lispsys+47*4 # array_name + .long NIL # nothing here + .long _lispsys+50*4 # sdot_name + .long _lispsys+53*4 # val_nam + .long NIL # hunk2_nam + .long NIL # hunk4_nam + .long NIL # hunk8_nam + .long NIL # hunk16_nam + .long NIL # hunk32_nam + .long NIL # hunk64_nam + .long NIL # hunk128_nam + .long _lispsys+124*4 # vector_nam + .long _lispsys+125*4 # vectori_nam + +/* Quickly allocate small fixnums */ + + .globl _qnewint +_qnewint: + Profile + cmpl r5,$1024 + jgeq alloc + cmpl r5,$-1024 + jlss alloc + moval _Fixzero[r5],r0 + rsb +alloc: + movl _int_str,r0 # move next cell addr to r0 + jlss callnewi # if no space, allocate + incl *_lispsys+24*4 # inc count of ints + movl (r0),_int_str # advance free list + movl r5,(r0) # put baby to bed. + rsb +callnewi: + pushl r5 + calls $0,_newint + movl (sp)+,(r0) + rsb + + +/* _qoneplus adds one to the boxed fixnum in r0 + * and returns a boxed fixnum. + */ + + .globl _qoneplus +_qoneplus: + Profile2 + addl3 (r0),$1,r5 +#ifdef PORTABLE + movl r6,NP + movl r6,LBOT +#endif + jmp _qnewint + +/* _qoneminus subtracts one from the boxes fixnum in r0 and returns a + * boxed fixnum + */ + .globl _qoneminus +_qoneminus: + Profile2 + subl3 $1,(r0),r5 +#ifdef PORTABLE + movl r6,NP + movl r6,LBOT +#endif + jmp _qnewint + +/* + * _qnewdoub quick allocation of a initialized double (float) cell. + * This entry point is required by the compiler for symmetry reasons. + * Passed to _qnewdoub in r4,r5 is a double precision floating point + * number. This routine allocates a new cell, initializes it with + * the given value and then returns the cell. + */ + + .globl _qnewdoub +_qnewdoub: + Profile + movl _doub_str,r0 # move next cell addr to r0 + jlss callnewd # if no space, allocate + incl *_lispsys+30*4 # inc count of doubs + movl (r0),_doub_str # advance free list + movq r4,(r0) # put baby to bed. + rsb + +callnewd: + movq r4,-(sp) # stack initial value + calls $0,_newdoub + movq (sp)+,(r0) # restore initial value + rsb + + .globl _qcons + +/* + * quick cons call, the car and cdr are stacked on the namestack + * and this function is jsb'ed to. + */ + +_qcons: + Profile + movl _dtpr_str,r0 # move next cell addr to r0 + jlss getnew # if ran out of space jump + incl *_lispsys+28*4 # inc count of dtprs + movl (r0),_dtpr_str # advance free list +storit: + movl -(r6),(r0) # store in cdr + movl -(r6),4(r0) # store in car + rsb + +getnew: +#ifdef PORTABLE + movl r6,NP + movab -8(r6),LBOT +#endif + calls $0,_newdot # must gc to get one + jbr storit # now initialize it. + +/* + * Fast equivalent of newdot, entered by jsb + */ + + .globl _qnewdot +_qnewdot: + Profile + movl _dtpr_str,r0 # mov next cell addr t0 r0 + jlss mustallo # if ran out of space + incl *_lispsys+28*4 # inc count of dtprs + movl (r0),_dtpr_str # advance free list + clrq (r0) + rsb +mustallo: + calls $0,_newdot + rsb + +/* prunel - return a list of dtpr cells to the free list + * this is called by the pruneb after it has discarded the top bignum + * the dtpr cells are linked through their cars not their cdrs. + * this returns with an rsb + * + * method of operation: the dtpr list we get is linked by car's so we + * go through the list and link it by cdr's, then have the last dtpr + * point to the free list and then make the free list begin at the + * first dtpr. + */ +qprunel: + movl r0,r2 # remember first dtpr location +rep: decl *_lispsys+28*4 # decrement used dtpr count + movl 4(r0),r1 # put link value into r1 + jeql endoflist # if nil, then end of list + movl r1,(r0) # repl cdr w/ save val as car + movl r1,r0 # advance to next dtpr + jbr rep # and loop around +endoflist: + movl _dtpr_str,(r0) # make last 1 pnt to free list + movl r2,_dtpr_str # & free list begin at 1st 1 + rsb + +/* + * qpruneb - called by the arithmetic routines to free an sdot and the dtprs + * which hang on it. + * called by + * pushl sdotaddr + * jsb _qpruneb + */ + .globl _qpruneb +_qpruneb: + Profile + movl 4(sp),r0 # get address + decl *_lispsys+48*4 # decr count of used sdots + movl _sdot_str,(r0) # have new sdot point to free list + movl r0,_sdot_str # start free list at new sdot + movl 4(r0),r0 # get address of first dtpr + jneq qprunel # if exists, prune it + rsb # else return. + + +/* + * _qprunei + * called by the arithmetic routines to free a fixnum cell + * calling sequence + * pushl fixnumaddr + * jsb _qprunei + */ + + .globl _qprunei +_qprunei: + Profile + movl 4(sp),r0 # get address of fixnum + cmpl r0,$_Lastfix # is it a small fixnum + jleq skipit # if so, leave + decl *_lispsys+24*4 # decr count of used ints + movl _int_str,(r0) # link the fixnum into the free list + movl r0,_int_str +skipit: + rsb + + + .globl _qpopnames +_qpopnames: # equivalent of C-code popnames, entered by jsb. + movl (sp)+,r0 # return address + movl (sp)+,r1 # Lower limit + movl _bnp,r2 # pointer to bind stack entry +qploop: + subl2 $8,r2 # for(; (--r2) > r1;) { + cmpl r2,r1 # test for done + jlss qpdone + movl (r2),*4(r2) # r2->atm->a.clb = r2 -> val; + brb qploop # } +qpdone: + movl r1,_bnp # restore bnp + jmp (r0) # return + +/* + * _qget : fast get subroutine + * (get 'atom 'ind) + * called with -8(r6) equal to the atom + * -4(r6) equal to the indicator + * no assumption is made about LBOT + * unfortunately, the atom may not in fact be an atom, it may + * be a list or nil, which are special cases. + * For nil, we grab the nil property list (stored in a special place) + * and for lists we punt and call the C routine since it is most likely + * and error and we havent put in error checks yet. + */ + + .globl _qget +_qget: + Profile + movl -4(r6),r1 # put indicator in r1 + movl -8(r6),r0 # and atom into r0 + jeql nilpli # jump if atom is nil + ashl $-9,r0,r2 # check type + cmpb _typetable+1[r2],$1 # is it a symbol?? + jneq notsymb # nope + movl 4(r0),r0 # yes, put prop list in r1 to begin scan + jeql fail # if no prop list, we lose right away +lp: cmpl r1,4(r0) # is car of list eq to indicator? + jeql good # jump if so + movl *(r0),r0 # else cddr down list + jneq lp # and jump if more list to go. + +fail: subl2 $8,NP # unstack args + rsb # return with r0 eq to nil + +good: movl (r0),r0 # return cadr of list + movl 4(r0),r0 + subl2 $8,NP #unstack args + rsb + +nilpli: movl _lispsys+64*4,r0 # want nil prop list, get it specially + jneq lp # and process if anything there + subl2 $8,NP #unstack args + rsb # else fail + +notsymb: +#ifdef PORTABLE + movl r6,NP + movab -8(r6),LBOT # must set up LBOT before calling +#else + movab -8(r6),LBOT # must set up LBOT before calling +#endif + calls $0,_Lget # not a symbol, call C routine to error check + subl2 $8,NP #unstack args + rsb # and return what it returned. + +/* + * _qexarith exact arithmetic + * calculates x=a*b+c where a,b and c are 32 bit 2's complement integers + * whose top two bits must be the same (i.e. the are members of the set + * of valid fixnum values for Franz Lisp). The result, x, will be 64 bits + * long but since each of a, b and c had only 31 bits of precision, the + * result x only has 62 bits of precision. The lower 30 bits are returned + * in *plo and the high 32 bits are returned in *phi. If *phi is 0 or -1 then + * x doesn't need any more than 31 bits plus sign to describe, so we + * place the sign in the high two bits of *plo and return 0 from this + * routine. A non zero return indicates that x requires more than 31 bits + * to describe. + */ + + .globl _qexarith +/* qexarith(a,b,c,phi,plo) + * int *phi, *plo; + */ +_qexarith: + emul 4(sp),8(sp),12(sp),r2 #r2 = a*b + c to 64 bits + extzv $0,$30,r2,*20(sp) #get new lo + extv $30,$32,r2,r0 #get new carry + beql out # hi = 0, no work necessary + movl r0,*16(sp) # save hi + mcoml r0,r0 # Is hi = -1 (it'll fit in one word) + bneq out # it doesn't + bisl2 $0xc0000000,*20(sp) # alter low so that it is ok. +out: rsb + + + +/* + * pushframe : stack a frame + * When this is called, the optional arguments and class have already been + * pushed on the stack as well as the return address (by virtue of the jsb) + * , we push on the rest of the stuff (see h/frame.h) + * for a picture of the save frame + */ + .globl _qpushframe + +_qpushframe: + Profile + movl _errp,-(sp) + movl _bnp,-(sp) + movl NP,-(sp) + movl LBOT,-(sp) + pushr $0x3f00 # save r13(fp), r12(ap),r11,r10,r9,r8 + movab 6*4(sp),r0 # return addr of lbot on stack + clrl _retval # set retval to C_INITIAL +#ifndef SPISFP + jmp *40(sp) # return through return address +#else + movab -4(sp),sp + movl sp,(sp) + movl _xsp,-(sp) + jmp *48(sp) +#endif + +/* + * Ipushf : stack a frame, where space is preallocated on the stack. + * this is like pushframe, except that it doesn't alter the stack pointer + * and will save more registers. + * This might be written a little more quickly by having a bigger register + * save mask, but this is only supposed to be an example for the + * IBM and RIDGE people. + */ + +#ifdef SPISFP + .globl _Ipushf +_Ipushf: + .word 0 + addl3 $96,16(ap),r1 + movl 12(ap),-(r1) + movl 8(ap),-(r1) + movl 4(ap),-(r1) + movl 16(fp),-(r1) + movl _errp,-(r1) + movl _bnp,-(r1) + movl NP,-(r1) + movl LBOT,-(r1) + movl r1,r0 + movq 8(fp),-(r1) /* save stuff in the same order unix saves them + (r13,r12,r11,r10,r9,r8) and then add extra + for vms (sp,r7,r6,r5,r4,r3,r2) */ + movq r10,-(r1) + movq r8,-(r1) + movab 20(ap),-(r1) /* assumes Ipushf allways called by calls, with + the stack alligned */ + movl _xsp,-(r1) + movq r6,-(r1) + movq r4,-(r1) + movq r2,-(r1) + clrl _retval + ret +#endif +/* + * qretfromfr + * called with frame to ret to in r11. The popnames has already been done. + * we must restore all registers, and jump to the ret addr. the popping + * must be done without reducing the stack pointer since an interrupt + * could come in at any time and this frame must remain on the stack. + * thus we can't use popr. + */ + + .globl _qretfromfr + +_qretfromfr: + Profile + movl r11,r0 # return error frame location + subl3 $24,r11,sp # set up sp at bottom of frame + movl sp,r1 # prepare to pop off + movq (r1)+,r8 # r8,r9 + movq (r1)+,r10 # r10,r11 + movq (r1)+,r12 # r12,r13 + movl (r1)+,LBOT # LBOT (lbot) + movl (r1)+,NP # NP (np) + jmp *40(sp) # jump out of frame + +#ifdef SPISFP + +/* + * this is equivalent to qretfro for a native VMS system + * + */ + .globl _Iretfrm +_Iretfrm: + .word 0 + movl 4(ap),r0 # return error frame location + movl r0,r1 + movq -(r1),ap + movq -(r1),r10 + movq -(r1),r8 + movl -(r1),sp + movl -(r1),_xsp + movq -(r1),r6 + movq -(r1),r4 + movq -(r1),r2 + movl r0,r1 + movl (r1)+,LBOT + movl (r1)+,NP + jmp *16(r0) +#endif + +/* + * this routine finishes setting things up for dothunk + * it is code shared to keep the size of c-callable thunks + * for lisp functions, small. + */ + .globl _thcpy +_thcpy: + movl (sp),r0 + pushl ap + pushl (r0)+ + pushl (r0)+ + calls $4,_dothunk + ret +/* + * This routine gets the name of the inital entry point + * It is here so it can be under ifdef control. + */ + .globl _gstart +_gstart: + .word 0 +#if os_vms + moval _$$$start,r0 +#else + moval start,r0 +#endif + ret + .globl _proflush +_proflush: + .word 0 + ret + +/* + * The definition of mcount must be present even when the C code + * isn't being profiled, since lisp code may reference it. + */ + +#ifndef os_vms +.globl mcount +mcount: +#endif + +.globl _mcount +_mcount: + +#ifdef PROF + movl (r0),r1 + bneq incr + movl _countbase,r1 + beql return + addl2 $8,_countbase + movl (sp),(r1)+ + movl r1,(r0) +incr: + incl (r1) +return: +#endif + rsb + + +/* This must be at the end of the file. If we are profiling, allocate + * space for the profile buffer + */ +#ifdef PROF + .data + .comm _countbase,4 + .lcomm prbuf,indx+4 + .text +#endif -- 2.20.1