/[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.2 by wlott, Fri Sep 7 17:39:47 1990 UTC revision 1.3 by ram, Thu Nov 29 01:55:43 1990 UTC
# Line 967  explicitly marked saying who wrote it. Line 967  explicitly marked saying who wrote it.
967  );end of Vaxlisp (and dec vax common)  );end of Vaxlisp (and dec vax common)
968    
969    
970  ;;; Implementation of funcallable instances for CMU Common Lisp.  ;;;; Implementation of funcallable instances for CMU Common Lisp:
971  ;;;  ;;;
972    ;;;    We represent a FIN like a closure, but the header has a distinct type
973    ;;; tag.  The FIN data slots are stored at the end of a fixed-length closure
974    ;;; (at FIN-DATA-OFFSET.)  When the function is set to a closure that has no
975    ;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN
976    ;;; with the closure slots.  If the closure has too many slots, we must
977    ;;; indirect through a trampoline with a rest arg.  For non-closures, we just
978    ;;; set the function slot.
979    ;;;
980    ;;;    We can get away with this efficient and relatively simple scheme because
981    ;;; the compiler currently currently only references closure slots during the
982    ;;; initial call and on entry into the function.  So we don't have to worry
983    ;;; about bad things happening when the FIN is clobbered (the problem JonL
984    ;;; flames about somewhere...)
985    ;;;
986    ;;;    We also stick in a slot for the function name at the end, but before the
987    ;;; data slots.
988    
989  #+:CMU  #+CMU
990  (progn  (import 'kernel:funcallable-instance-p)
   
 (defstruct funcallable-instance-info  
   (function #'(lambda (&rest args) (declare (ignore args))  
                 (called-fin-without-function))  
             :type function)  
   (name "Unnamed funcallable instance")  
   . #.funcallable-instance-data)  
   
 (proclaim '(inline funcallable-instance-info funcallable-instance-p))  
991    
992    #+CMU
993    (progn
994    
995  (defun funcallable-instance-info (fin)  (eval-when (compile load eval)
996    (system:find-if-in-closure #'funcallable-instance-info-p fin))    ;;; The offset of the function's name & the max number of real closure slots.
997      ;;;
998      (defconstant fin-name-slot 14)
999    
1000      ;;; The offset of the data slots.
1001      ;;;
1002      (defconstant fin-data-offset 15))
1003    
1004    
1005    ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1  --  Interface
1006    ;;;
1007    ;;;    Allocate a funcallable instance, setting the function to an error
1008    ;;; function and initializing the data slots to NIL.
1009    ;;;
1010  (defun allocate-funcallable-instance-1 ()  (defun allocate-funcallable-instance-1 ()
1011    (let ((info (make-funcallable-instance-info)))    (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
1012      #'(lambda (&rest args)           (res (kernel:%make-funcallable-instance
1013          (apply (funcallable-instance-info-function info) args))))                 len
1014                   #'called-fin-without-function)))
1015        (dotimes (i (length funcallable-instance-data))
1016          (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
1017        (kernel:%set-funcallable-instance-info res fin-name-slot nil)
1018        res))
1019    
1020    
1021  (defun funcallable-instance-p (thing)  ;;; FUNCALLABLE-INSTANCE-P  --  Interface
1022    (and (functionp thing)  ;;;
1023         (= (kernel:get-type thing) vm:closure-header-type)  ;;;    Return true if X is a funcallable instance.  This is an interpreter
1024         (funcallable-instance-info thing)  ;;; stub; the compiler directly implements this function.
1025         t))  ;;;
1026    (defun funcallable-instance-p (x) (funcallable-instance-p x))
1027    
1028    
1029    ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
1030    ;;;
1031    ;;;    Set the function that is called when FIN is called.
1032    ;;;
1033  (defun set-funcallable-instance-function (fin new-value)  (defun set-funcallable-instance-function (fin new-value)
1034    (setf (funcallable-instance-info-function (funcallable-instance-info fin))    (assert (funcallable-instance-p fin))
1035          new-value))    (ecase (kernel:get-type new-value)
1036        (#.vm:closure-header-type
1037         (let ((len (- (kernel:get-closure-length new-value)
1038                       (1- vm:closure-info-offset))))
1039           (cond ((> len fin-name-slot)
1040                  (set-funcallable-instance-function
1041                   fin
1042                   #'(lambda (&rest args)
1043                       (apply new-value args))))
1044                 (t
1045                  (dotimes (i fin-data-offset)
1046                    (kernel:%set-funcallable-instance-info
1047                     fin i
1048                     (if (>= i len)
1049                         nil
1050                         (kernel:%closure-index-ref new-value i))))
1051                  (kernel:%set-funcallable-instance-function
1052                   fin
1053                   (kernel:%closure-function new-value))
1054                  new-value))))
1055        (#.vm:function-header-type
1056         (kernel:%set-funcallable-instance-function fin new-value))))
1057    
1058    
1059    ;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME  --  Interface
1060    ;;;
1061    ;;;    Read or set the name slot in a funcallable instance.
1062    ;;;
1063  (defun funcallable-instance-name (fin)  (defun funcallable-instance-name (fin)
1064    (funcallable-instance-info-name (funcallable-instance-info fin)))    (kernel:%closure-index-ref fin fin-name-slot))
1065    ;;;
1066  (defun set-funcallable-instance-name (fin new-value)  (defun set-funcallable-instance-name (fin new-value)
1067    (setf (funcallable-instance-info-name (funcallable-instance-info fin))    (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)
1068          new-value))    new-value)
1069    ;;;
1070  (defsetf funcallable-instance-name set-funcallable-instance-name)  (defsetf funcallable-instance-name set-funcallable-instance-name)
1071    
1072    
1073    ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface
1074    ;;;
1075    ;;;    If the slot is constant, use CLOSURE-REF with the appropriate offset,
1076    ;;; otherwise do a run-time lookup of the slot offset.
1077    ;;;
1078  (defmacro funcallable-instance-data-1 (fin slot)  (defmacro funcallable-instance-data-1 (fin slot)
1079    (unless (and (listp slot) (eq (car slot) 'quote))    (if (constantp slot)
1080      (error "Non-constant name for funcallable-instance-data-1: ~S" slot))        `(sys:%primitive c:closure-ref ,fin
1081    `(,(intern (concatenate 'simple-string                         (+ (or (position ,slot funcallable-instance-data)
1082                            "FUNCALLABLE-INSTANCE-INFO-"                                (error "Unknown slot: ~S." ,slot))
1083                            (string (cadr slot)))                            fin-data-offset))
1084               *the-pcl-package*)        (ext:once-only ((n-slot slot))
1085      (funcallable-instance-info ,fin)))          `(kernel:%closure-index-ref
1086              ,fin
1087              (+ (or (position ,n-slot funcallable-instance-data)
1088  ); End of :CMU                   (error "Unknown slot: ~S." ,n-slot))
1089                 fin-data-offset)))))
1090    ;;;
1091    (defmacro %set-funcallable-instance-data-1 (fin slot new-value)
1092      (ext:once-only ((n-fin fin)
1093                      (n-slot slot))
1094        `(kernel:%set-funcallable-instance-info
1095          ,n-fin
1096          (+ (or (position ,n-slot funcallable-instance-data)
1097                 (error "Unknown slot: ~S." ,n-slot))
1098             fin-data-offset)
1099          ,new-value)))
1100    ;;;
1101    (defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)
1102    
1103    ); End of #+cmu progn
1104    
1105    
1106    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5