![[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.