BSD 4 release

[unix-history] / usr / src / cmd / lisp / qfuncl.s

diff --git a/usr/src/cmd/lisp/qfuncl.s b/usr/src/cmd/lisp/qfuncl.s
index 4b87e4b..5b3996a 100644 (file)
--- a/usr/src/cmd/lisp/qfuncl.s
+++ b/usr/src/cmd/lisp/qfuncl.s
@@ -1,3 +1,5 @@
+
+       .asciz  "@(#)qfuncl.s   34.1    10/3/80"

 #  opus 30 compiler call to ??? interface routines
        .globl  __qf0
 __qf0:
 #  opus 30 compiler call to ??? interface routines
        .globl  __qf0
 __qf0:


@@ -24,24 +26,35 @@ __qf4:
        subl3   $20,r6,r7
        jbr     __qfuncl
 
        subl3   $20,r6,r7
        jbr     __qfuncl
 

+       .data
+qfunbuf: .long 0
+qlinbuf: .long 0
+       .text

        .globl  __qfuncl
 __qfuncl:                              # quick function call
        .globl  __qfuncl
 __qfuncl:                              # quick function call

+#      movab   qfunbuf,r0              # profiling
+#      jsb     mcount                  # profiling

        cmpl    r6,_nplim               # make sure stack ok
        blss    on1
        calls   $0,_namerr
 on1:   movl    (r7),r0                 # bring in addr of atom
        cmpl    r6,_nplim               # make sure stack ok
        blss    on1
        calls   $0,_namerr
 on1:   movl    (r7),r0                 # bring in addr of atom

+       addl2   $4,r7                   # inc lbot by one nament

        pushl   r0                      # stack addr of atom of fcn to call
        movl    8(r0),r0                # bring in fcn binding addr
        jleq    nonexf                  # jump if fcn non existant
        pushl   r0                      # stack addr of atom of fcn to call
        movl    8(r0),r0                # bring in fcn binding addr
        jleq    nonexf                  # jump if fcn non existant

+       tstl    _rsetsw                 # see if in *rset mode
+       jeql    norset                  # if not, call function
+       tstl    _bcdtrsw                # if (*rset t) & (sstatus bcdtrace t)
+       jneq    hackit                  # then have Lfuncal do the work
+norset:        

        ashl    $-9,r0,r1               # see if bcd
        cmpb    $5,_typetable+1[r1]     # we are calling
        jeql    gotbcd
 hackit:
        calls   $1,_Lfuncal             # call lisp stuff
        ashl    $-9,r0,r1               # see if bcd
        cmpb    $5,_typetable+1[r1]     # we are calling
        jeql    gotbcd
 hackit:
        calls   $1,_Lfuncal             # call lisp stuff

-       movl    r7,r6                   # restore np to top
+       movab   -4(r7),r6               # restore np to top

        rsb                             # return to callee
 gotbcd:
        rsb                             # return to callee
 gotbcd:

-       addl2   $4,r7                   # inc lbot by one nament

        calls   $1,*(r0)                # call code
        movab   -4(r7),r6               # restore np to top
        rsb                             # return
        calls   $1,*(r0)                # call code
        movab   -4(r7),r6               # restore np to top
        rsb                             # return


@@ -52,10 +65,57 @@ nonexf: # non existant function, call c function to take care of it,
        # we should never return from this call
        # the addr of the atom is already stacked
 
        # we should never return from this call
        # the addr of the atom is already stacked
 

+#      addl2   $4,r7                   # inc lbot by one nament for evalframe

        calls   $1,_Undeff              # call handler
        clrl    r0                      # return nil to compiled code
        rsb                             # if ever should return here
 
        calls   $1,_Undeff              # call handler
        clrl    r0                      # return nil to compiled code
        rsb                             # if ever should return here
 

+
+
+# transfer  table linkage routine 
+#
+       .globl  _qlinker
+_qlinker:
+       .word   0xfc0                   # save all possible registers 
+#      movab   qlinbuf,r0              # profiling
+#      jsb     mcount                  # profiling
+       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    8(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    $5,_typetable+1[r3]     
+       jeql    linkin                  # bcd, link it in!
+nolink:
+       pushl   r1                      # non, bcd, call interpreter
+       calls   $1,_Lfuncal
+       ret
+
+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   r1                      # non existant fcn
+       calls   $1,_Undeff              # call processor
+       movl    r0,r1                   # back in r1
+       jbr     retry                   # for the retry.
+
+

        .globl  __erthrow               # errmessage for uncaught throws
 __erthrow: 
        .byte   'U,'n,'c,'a,'u,'g,'h,'t,' ,'t,'h,'r,'o,'w
        .globl  __erthrow               # errmessage for uncaught throws
 __erthrow: 
        .byte   'U,'n,'c,'a,'u,'g,'h,'t,' ,'t,'h,'r,'o,'w


@@ -76,9 +136,123 @@ _tynames:
        .long   0                               # nothing here
        .long   _lispsys+50*4   # sdot_name
        .long   _lispsys+53*4   # val_nam
        .long   0                               # nothing here
        .long   _lispsys+50*4   # sdot_name
        .long   _lispsys+53*4   # val_nam

+#
+#      Quickly allocate small fixnums
+#
+       .globl  _qnewint
+_qnewint:
+       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
+       .globl  _qcons
+
+# quick cons call, the car and cdr are stacked on the namestack
+# and this function is jsb'ed to.
+
+_qcons:
+       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:        calls   $0,_newdot      # must gc to get one
+       jbr     storit          # now initialize it.
+
+#
+# Fast equivalent of newdot, entered by jsb
+#
+       .globl  _qnewdot
+_qnewdot:
+       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
+       .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 r7
+# 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.
+#
+       .data
+qgtbf: .word   0               # for profiling
+       .text

 
 

+       .globl  _qget
+_qget: 
+#      movab   qgtbf,r0        # these instructions are for profiling
+#      jsb     mcount
+       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,r6           # unstack args
+       rsb                     # return with r0 eq to nil

 
 

+good:  movl    (r0),r0         # return cadr of list
+       movl    4(r0),r0
+       subl2   $8,r6           #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,r6           #unstack args
+       rsb                     # else fail
+       
+notsymb:
+       movab   -8(r6),r7       # must set up r7 before calling
+       calls   $0,_Lget        # not a symbol, call C routine to error check
+       subl2   $8,r6           #unstack args
+       rsb                     # and return what it returned.