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