/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Diff of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by phg, Tue Jan 12 18:24:48 1993 UTC revision 1.9.1.1 by ram, Tue Jul 20 19:04:51 1993 UTC
# Line 1247  dbg: Line 1247  dbg:
1247    
1248  ;;;; Implementation of funcallable instances for CMU Common Lisp:  ;;;; Implementation of funcallable instances for CMU Common Lisp:
1249  ;;;  ;;;
1250  ;;;    We represent a FIN like a closure, but the header has a distinct type  (defstruct (pcl-funcallable-instance
1251  ;;; tag.  The FIN data slots are stored at the end of a fixed-length closure              (:alternate-metaclass kernel:funcallable-instance
1252  ;;; (at FIN-DATA-OFFSET.)  When the function is set to a closure that has no                                    kernel:random-pcl-class
1253  ;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN                                    kernel:make-random-pcl-class)
1254  ;;; with the closure slots.  If the closure has too many slots, we must              (:type kernel:funcallable-structure)
1255  ;;; indirect through a trampoline with a rest arg.  For non-closures, we just              (:constructor allocate-funcallable-instance-1 ())
1256  ;;; set the function slot.              (:conc-name nil))
1257  ;;;    ;;
1258  ;;;    We can get away with this efficient and relatively simple scheme because    ;; PCL wrapper is in the layout slot.
1259  ;;; the compiler currently currently only references closure slots during the    ;;
1260  ;;; initial call and on entry into the function.  So we don't have to worry    ;; PCL data vector.
1261  ;;; about bad things happening when the FIN is clobbered (the problem JonL    (pcl-funcallable-instance-slots nil)
1262  ;;; flames about somewhere...)    ;;
1263  ;;;    ;; The debug-name for this function.
1264  ;;;    We also stick in a slot for the function name at the end, but before the    (funcallable-instance-name nil))
 ;;; data slots.  
1265    
1266  #+CMU  #+CMU
1267    ;;; Note: returns true for non-pcl funcallable structures.
1268  (import 'kernel:funcallable-instance-p)  (import 'kernel:funcallable-instance-p)
1269    
1270  #+CMU  #+CMU
1271  (progn  (progn
   
 (eval-when (compile load eval)  
   ;;; The offset of the function's name & the max number of real closure slots.  
   ;;;  
   (defconstant fin-name-slot 14)  
   
   ;;; The offset of the data slots.  
   ;;;  
   (defconstant fin-data-offset 15))  
   
   
 ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1  --  Interface  
 ;;;  
 ;;;    Allocate a funcallable instance, setting the function to an error  
 ;;; function and initializing the data slots to NIL.  
 ;;;  
 (defun allocate-funcallable-instance-1 ()  
   (let* ((len (+ (length funcallable-instance-data) fin-data-offset))  
          (res (kernel:%make-funcallable-instance  
                len  
                #'called-fin-without-function)))  
     (dotimes (i (length funcallable-instance-data))  
       (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))  
     (kernel:%set-funcallable-instance-info res fin-name-slot nil)  
     res))  
   
   
 ;;; FUNCALLABLE-INSTANCE-P  --  Interface  
 ;;;  
 ;;;    Return true if X is a funcallable instance.  This is an interpreter  
 ;;; stub; the compiler directly implements this function.  
 ;;;  
 (defun funcallable-instance-p (x) (funcallable-instance-p x))  
   
   
1272  ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface  ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
1273  ;;;  ;;;
1274  ;;;    Set the function that is called when FIN is called.  ;;;    Set the function that is called when FIN is called.
# Line 1311  dbg: Line 1276  dbg:
1276  (defun set-funcallable-instance-function (fin new-value)  (defun set-funcallable-instance-function (fin new-value)
1277    (declare (type function new-value))    (declare (type function new-value))
1278    (assert (funcallable-instance-p fin))    (assert (funcallable-instance-p fin))
1279    (ecase (kernel:get-type new-value)    (setf (kernel:funcallable-instance-function fin) new-value))
     (#.vm:closure-header-type  
      (let ((len (- (kernel:get-closure-length new-value)  
                    (1- vm:closure-info-offset))))  
        (cond ((> len fin-name-slot)  
               (set-funcallable-instance-function  
                fin  
                #'(lambda (&rest args)  
                    (apply new-value args))))  
              (t  
               (dotimes (i fin-data-offset)  
                 (kernel:%set-funcallable-instance-info  
                  fin i  
                  (if (>= i len)  
                      nil  
                      (kernel:%closure-index-ref new-value i))))  
               (kernel:%set-funcallable-instance-function  
                fin  
                (kernel:%closure-function new-value))))))  
     (#.vm:function-header-type  
      (kernel:%set-funcallable-instance-function fin new-value)))  
   new-value)  
   
   
 ;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME  --  Interface  
 ;;;  
 ;;;    Read or set the name slot in a funcallable instance.  
 ;;;  
 (defun funcallable-instance-name (fin)  
   (kernel:%closure-index-ref fin fin-name-slot))  
 ;;;  
 (defun set-funcallable-instance-name (fin new-value)  
   (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)  
   new-value)  
 ;;;  
 (defsetf funcallable-instance-name set-funcallable-instance-name)  
1280    
1281    
1282  ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface  ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface
1283  ;;;  ;;;
1284  ;;;    If the slot is constant, use CLOSURE-REF with the appropriate offset,  ;;;    This "works" on non-PCL FINs, which allows us to weaken
1285  ;;; otherwise do a run-time lookup of the slot offset.  ;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs.  This is also
1286    ;;; necessary for bootstrapping to work, since the layouts for early GFs are
1287    ;;; not initially initialized.
1288  ;;;  ;;;
1289  (defmacro funcallable-instance-data-1 (fin slot)  (defmacro funcallable-instance-data-1 (fin slot)
1290    (if (constantp slot)    (ecase (eval slot)
1291        `(sys:%primitive c:closure-ref ,fin      (wrapper `(kernel:%funcallable-instance-layout ,fin))
1292                         ,(+ (or (position (eval slot) funcallable-instance-data)      (slots `(kernel:%funcallable-instance-info ,fin 0))))
1293                                 (error "Unknown slot: ~S." (eval slot)))  
1294                             fin-data-offset))  (defmacro pcl-funcallable-instance-wrapper (x)
1295        (ext:once-only ((n-slot slot))    `(kernel:%funcallable-instance-layout ,x))
         `(kernel:%closure-index-ref  
           ,fin  
           (+ (or (position ,n-slot funcallable-instance-data)  
                  (error "Unknown slot: ~S." ,n-slot))  
              fin-data-offset)))))  
 ;;;  
 (defmacro %set-funcallable-instance-data-1 (fin slot new-value)  
   (ext:once-only ((n-fin fin)  
                   (n-slot slot)  
                   (n-val new-value))  
     `(progn  
        (kernel:%set-funcallable-instance-info  
         ,n-fin  
         ,(if (constantp slot)  
              (+ (or (position (eval slot) funcallable-instance-data)  
                     (error "Unknown slot: ~S." (eval slot)))  
                 fin-data-offset)  
              `(+ (or (position ,n-slot funcallable-instance-data)  
                      (error "Unknown slot: ~S." ,n-slot))  
                  fin-data-offset))  
         ,n-val)  
        ,n-val)))  
 ;;;  
 (defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)  
1296    
1297  ); End of #+cmu progn  ); End of #+cmu progn
1298    
# Line 1957  make_turbo_trampoline_internal(base0) Line 1865  make_turbo_trampoline_internal(base0)
1865    
1866  (defmacro fsc-instance-slots (fin)  (defmacro fsc-instance-slots (fin)
1867    `(funcallable-instance-data-1 ,fin 'slots))    `(funcallable-instance-data-1 ,fin 'slots))
   
   
   

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.9.1.1

  ViewVC Help
Powered by ViewVC 1.1.5