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