4.4BSD/usr/src/old/lisp/franz/68k/qfuncl.c
/*
*$Header: qfuncl.c,v 1.9 84/02/29 17:23:24 sklower Exp $
*$Locker: $
*
* Copyright (c) 1982, by the Regents, University of California
*
* -[Tue Mar 22 15:42:27 1983 by layer]-
*
* "quick" functions file.
*
* 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
/* register defines */
#define FIXREG d2
#ifdef NPINREG
#define _np a2
#define _lbot d3
#endif
#ifdef PROF
.set indx,0
#define Profile \
lea prbuf+indx,a0 \
.set indx,indx+4 \
jsr mcount
#define Profile2 \
movl a0,sp@-
lea prbuf+indx,a0 \
.set indx,indx+4 \
jsr mcount
movl sp@+,a0
#else
#define Profile
#define Profile2
#endif
#ifdef PORTABLE
#define NILtest(p) cmpl #/**/OFFSET,p
#define NILsub(p) subl #/**/OFFSET,p
#else
#define NILtest(p)
#define NILsub(p)
#endif
.text
/* transfer table linkage routine */
.globl _qlinker
_qlinker:
Profile
link a6,#-28
tstb sp@(-132)
moveml #036000,a6@(-28) |a(2,3,4,5)
tstl _exception |any pending exceptions
jeq noexc
tstl _sigintcnt |is it because of SIGINT
jeq noexc |if not, just leave
movl #2,sp@- |else push SIGINT
jsr _sigcall
noexc:
movl a6@(4),a4 |get return pc
movl a4@(-6),a4 |get pointer to table
movl a4@(4),a5 |get atom pointer
retry: |come here after undeffunc err
movl a5@(8),a0 |get function binding
cmpl a0,d7 |if nil,
jeq nonex |then leave
tstl 2*4+_stattab |see if linkin posble (Strans)
jeq nolink |no, it isn't
movl a0,d0 |check type of function
NILsub(d0)
moveq #9,d1
asrl d1,d0
lea _typetable+1,a3
movb a3@(0,d0:L),d1
cmpb #/**/BCD,d1
jeq linkin |bcd, link it in!
cmpb #/**/ARRAY,d1 |how about array?
jeq doarray |yep
nolink:
movl a5,sp@- |non, bcd, call interpreter
jsr _Ifuncal
moveml a6@(-28),#036000
unlk a6
rts
/*
* handle arrays by pushing the array descriptor on the table and checking
* for a bcd array handler
*/
doarray:
movl a0@(Arrayaccfun),d0 |get access func addr shifted
NILsub(d0)
movl #9,d1
asrl d1,d0
lea _typetable+1,a3
cmpb #/**/BCD,a3@(0,d0:L) |bcd??
jne nolink |no, let funcal handle it
movl a0,a2@+ |store array header on stack
movl a2,_np
movl a0@,a0 |movl *(a0),a0 on VAX
movl a0@,a0
jsr a0@
subql #4,_np
moveml a6@(-28),#036000
unlk a6
rts
linkin:
movl a0@(4),d0 |check type of function discipline
NILsub(d0)
movl #9,d1
asrl d1,d0
lea _typetable+1,a3
cmpb #/**/STRNG,a3@(0,d0:L) |is it string?
jeq nolink |yes, it is a c call,
|so dont link in
movl a0@,a0 |get function addr
movl a0,a4@ |put fcn addr in table
jbsr a0@
moveml a6@(-28),#036000
unlk a6
rts
nonex: movl a4,sp@- |preserve table address
movl a5,sp@- |non existant fcn
jsr _Undeff |call processor
movl d0,a5 |back in r1
addql #4,sp
movl sp@+,a4 |restore table address
jra retry |for the retry.
.data
.globl __erthrow
__erthrow:
.asciz "Uncaught throw from compiled code"
.text
.globl _tynames
_tynames:
.long _nilatom |nothing here
.long 20*4+_lispsys |str_name
.long 21*4+_lispsys |atom_name
.long 19*4+_lispsys |int_name
.long 23*4+_lispsys |dtpr_name
.long 22*4+_lispsys |doub_name
.long 58*4+_lispsys |funct_name
.long 103*4+_lispsys |port_name
.long 47*4+_lispsys |array_name
.long _nilatom |nothing here
.long 50*4+_lispsys |sdot_name
.long 53*4+_lispsys |val_nam
.long _nilatom | hunk2_nam
.long _nilatom | hunk4_nam
.long _nilatom | hunk8_nam
.long _nilatom | hunk16_nam
.long _nilatom | hunk32_nam
.long _nilatom | hunk64_nam
.long _nilatom | hunk128_nam
.long 124*4+_lispsys |vector_nam
.long 125*4+_lispsys |vectori_nam
/* Quickly allocate small fixnums */
.globl _qnewint
_qnewint:
Profile
cmpl #1024,FIXREG
bge alloc
cmpl #-1024,FIXREG
bmi alloc
movl FIXREG,d0
asll #2,d0
addl #_Fixzero,d0
rts
alloc:
movl _int_str,a0 |move next cell addr to r0
NILtest(a0)
jmi callnewi |if no space, allocate
movl 4*24+_lispsys,a1
addql #1,a1@ |inc count of ints
movl a0@,_int_str |advance free list
movl FIXREG,a0@ |put baby to bed.
movl a0,d0
rts
callnewi:
movl FIXREG,sp@-
movl a2,_np |gc could occur
movl a2,_lbot
jsr _newint
movl d0,a0
movl sp@+,a0@
rts
/* _qoneplus adds one to the boxed fixnum in r0
* and returns a boxed fixnum.
*/
.globl _qoneplus
_qoneplus:
Profile
movl a0@,FIXREG
addql #1,FIXREG
bra _qnewint
/* _qoneminus subtracts one from the boxes fixnum in r0 and returns a
* boxed fixnum
*/
.globl _qoneminus
_qoneminus:
Profile
movl a0@,FIXREG
subql #1,FIXREG
bra _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 d0,d1 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,a0 |move next cell addr to r0
NILtest(a0)
jmi callnewd |if no space, allocate
|incl *_lispsys+30*4 |inc count of doubs
lea 30*4+_lispsys,a1
addl #1,a1@
movl a0@,_doub_str |advance free list
strdb:
movl d0,a0@ |put baby to bed.
movl d1,a0@(4) |put baby to bed.
rts
callnewd:
movl d0,sp@- |stack initial value
movl d1,sp@- |stack initial value
movl a2,_np |gc could occur
movl a2,_lbot
jsr _newdoub
movl d0,a0
movl sp@+,d1 |restore initial value
movl sp@+,d0 |restore initial value
bra strdb
/*
* quick cons call, the car and cdr are stacked on the namestack
* and this function is jsb'ed to.
*/
.globl _qcons
_qcons:
Profile
movl _dtpr_str,a0 |move next cell addr to a0
NILtest(a0)
jmi getnew |if ran out of space jump
movl 28*4+_lispsys,a1 |inc count of dtprs
addql #1,a1@
movl a0@,_dtpr_str |advance free list
storit: movl a2@-,a0@ |store in cdr
movl a2@-,a0@(4) |store in car
movl a0,d0
rts
getnew: movl a2,_np
jsr _newdot |must gc to get one
jra storit |now initialize it.
/*
* Fast equivalent of newdot, entered by jsb
*/
.globl _qnewdot
_qnewdot:
Profile
movl _dtpr_str,a0 |mov next cell addr t0 r0
NILtest(a0)
jmi mustallo |if ran out of space
movl a0,sp@-
movl 28*4+_lispsys,a0 |inc count of dtprs
addql #1,a0@
movl sp@+,a0
movl a0@,_dtpr_str |advance free list
clrl a0@ |clrq (r0)
clrl a0@(4)
rts
mustallo:
movl a2,_np |gc could occur
jsr _newdot
rts
/*
* this is called exactly like popnames would be from C
* but has been carefully improved so that it doesn't
* have to alter the stack.
*/
.globl _qpopnames
_qpopnames:
movl _bnp,a1
movl sp,a0
movl a0@(4),d0
jra .L130
.L20001:
movl a1@(4),a0
movl a1@,a0@
.L130:
subql #8,a1
cmpl a1,d0
jls .L20001
movl a1,_bnp
rts
/*
* _qget : fast get subroutine
* (get 'atom 'ind)
* called with a2@(-8) equal to the atom
* a2@(-4) 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 a2@(-4),a1 |put indicator in a1
movl a2@(-8),a0 |and atom into a0
cmpl a0,d7
jeq nilpli |jump if atom is nil
movl a0,d0 |check type
NILsub(d0)
movl #9,d1
asrl d1,d0
lea _typetable+1,a5
cmpb #/**/ATOM,a5@(0,d0:L) |is it a symbol??
jne notsymb |nope
movl a0@(4),a0 |yes, put prop list in
| a0 to begin scan
cmpl a0,d7
jeq fail |if no prop list,
| we lose right away
lp: cmpl a0@(4),a1 |is car of list = to indicator?
jeq good |jump if so
movl a0@,a0 |else cddr
movl a0@,a0 | down list
cmpl a0,d7
jne lp |and jump if more list to go.
fail: movl a0,d0
subql #8,a2
rts |return with a0 eq to nil
good: movl a0@,a0 |return cadr of list
movl a0@(4),d0
subql #8,a2
rts
nilpli: movl 64*4+_lispsys,a0 |want nil prop list,
| get it specially
cmpl a0,d7
jne lp |and process if anything there
movl a0,d0
subql #8,a2
rts |else fail
notsymb:
lea a2@(-8),a0 |set up lbot before callin
movl a0,_lbot
movl a2,_np
jsr _Lget |not a symbol, call C routine
| to error check
subql #8,a2
rts |and return what it returned.
/*
* 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 a0,d0 |remember first dtpr location
movl 28*4+_lispsys,a1 |dec count of dtprs
rep:
subql #1,a2@
movl a0@(4),a0@ |make cdr (forward lnk) == car
jeq endoflist |if nil, then end of list
movl a0@,a0 |advance to next dtpr
jra rep |and loop around
endoflist:
movl _dtpr_str,a0@ |make last 1 pnt to free list
movl d0,_dtpr_str |& free list begin at 1st one
rts
/*
* 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 48*4+_lispsys,a0 |decr count of used sdots
subql #1,a0@
movl sp@(4),a0 |get address
movl _sdot_str,a0@ |have new sdot pnt to free lst
movl a0,_sdot_str |strt free list at new sdot
movl a0@(4),a0 |get address of first dtpr
jne qprunel |if exists, prune it
rts |else return.
/*
* _qprunei
* called by the arithmetic routines to free a fixnum cell
* calling sequence
* pushl fixnumaddr
* jsb _qprunei
*/
.globl _qprunei
_qprunei:
Profile
movl a1,sp@-
movl sp@(4),a0 |get address of fixnum
cmpl #4*1023+_Fixzero,a0 |is it a small fixnum
jmi skipit |if so, leave
movl 24*4+_lispsys,a1 |decr count of used ints
subql #1,a1@
movl _int_str,a0@ |link the fixnum into the
| free list
movl a0,_int_str
skipit:
movl sp@+,a1
rts
Iclear:
clrl d0
rts
.text
.globl _Itstbt
_Itstbt:
movl a5,d1
NILsub(d1)
lsrl #2,d1
movl d1,d0
andl #7,d0
lsrl #3,d1
lea _bitmapi,a0
bset d0,a0@(0,d1:L)
beq .L14
moveq #1,d0
bra .L12
.L14:
clrl d0
.L12: rts
/*
* this routine returns an assembly language entry pt.
* it is put here to match the vax verison.
*/
.globl _gstart
.globl _proflush
_gstart:
movl #start,d0
_proflush:
rts
/*
* The definition of mcount must be present even when the C code
* isn't being profiled, since lisp code may reference it.
*/
.globl _mcount
#ifdef SunGotItsActTogetherAboutTakingMcountOutOfCrt0
.globl mcount
#endif
_mcount:
mcount:
#ifdef PROF
movl a0@,a1
jne incr
movl _countbase,a1
jeq return
addql #8,_countbase
movl sp@,a1@+
movl a1,a0@
incr:
addql #1,a1@
return:
#endif
rts
/*
* 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 _pushframe
.globl _qpushframe
.globl _Pushframe
_pushframe:
_qpushframe:
_Pushframe:
movl sp@,a0
movl _errp,sp@-
movl _bnp,sp@-
movl _np,sp@-
movl _lbot,sp@-
movl sp,d0 | return addr of lbot on stack
subl #56,sp
moveml #0x7cfc,sp@(12) | save fp,a5-a2,d7-d2
clrl _retval | set retval to C_INITIAL
#ifdef SPISFP
subl #8,sp
movl _xsp,sp@(16)
movl sp,sp@(12)
#endif
jmp a0@ | return through return address
#ifdef SPISFP
/*
* This is necessary on the sun-II beta testing version since the C
* compiler makes refence to temporaries and restoring registers relative
* to the stack pointer. See explicative comments in ../vax/qfuncl.c
* for Iretfrm and Ipushf
*/
.globl _Ipushf
_Ipushf:
movl sp@(16),a0
addl #96,a0
movl sp@(12),a0@-
movl sp@(8),a0@-
movl sp@(4),a0@-
movl sp@,a0@-
movl _errp,a0@-
movl _bnp,a0@-
movl _np,a0@-
movl _lbot,a0@-
movl a0,d0 | return addr of lbot on stack
moveml #0x7cfc,a0@(-44) | save fp,a5-a2,d7-d2
movl _xsp,a0@(-48)
movl sp,a0@(-52)
clrl _retval | set retval to C_INITIAL
rts
#endif
/*
* qretfromfr
* called with frame to ret to in a5. 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:
movl a5,d0 | return error frame location
movl a5,a0 | prepare to pop off
moveml a0@(-44),#0x7cfc | restore registers
#ifndef SPISFP
lea a0@(-56),sp
movl a0@+,_lbot
movl a0@+,_np
movl a0@(8),a0 | return address
jmp a0@
#else
movl a0@(-52),sp
movl a0@(-48),_xsp
movl a0@+,_lbot
movl a0@+,_np
movl a0@(8),sp@ | return address
rts
#endif
/*
* Ancillary code for small thunks generated so that
* c routines can be passed the address of something
* to call which will pass onto lisp functions
*/
.globl _thcpy
_thcpy:
movl sp@,a0
movl a0@+,sp@-
movl a0@+,sp@-
jsr _dothunk
lea sp@(12),sp
rts
#ifndef SPISFP
/* Copyright (c) 1982, Regents, University of California
This is here because for the sun II beta test version, you
can't do alloca */
.text
.globl _alloca
_alloca:
movl sp@,d0
movl sp@(4),d1
subl #1,d1
orl #3,d1
addl #1,d1
subl d1,sp
tstb sp@(-132)
movl d0,sp@
movl sp,d0
addl #8,d0
rts
#endif
.globl _vlsub
_vlsub:
movl sp@(4),a0
addql #8,a0
movl sp@(8),a1
addql #8,a1 | this should clear the carry bit.
#if sun_4_1c || sun_4_2beta
subxl a0@-,a1@-
subxl a0@-,a1@-
#else
subxl a1@-,a0@- | This is the correct version
subxl a1@-,a0@-
#endif
rts
/*
* We want to be able to redefine read and write to check
* certain lisp values. Rather than have 4 variants, we
* put the assembly language (obtained by adb rather than
* violating source) here under ifdef control.
*/
.globl __read
.globl __write
#if sun_4_1c || sun_4_2beta || sun_4_2
.globl _vadvise
__read:
pea 3:w
jmp _docall
__write:
pea 4:w
_docall:
trap #0
bcss _bad
_vadvise:
#endif
#ifdef os_masscomp
__read:
moveq #0x3,d0
jmp _docall
__write:
moveq #0x4,d0
_docall:
movl a7@(4),d1
movl a7@(8),a0
movl a7@(12),a1
trap #0
bcss _bad
#endif
#ifdef os_unisoft || os_unix_ts
.globl _vfork
_vfork:
jmp _fork
__read:
movw #0x3,d0
jmp _docall
__write:
movw #0x4,d0
_docall:
movl a7@(4),a0
movl a7@(8),d1
movl a7@(12),a1
trap #0x0
bcs _bad
#endif
rts
_bad:
jmp cerror
/* 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