Ignore:
Timestamp:
Mar 26, 2006, 3:23:00 AM (15 years ago)
Author:
gb
Message:

Mostly comment and formatting changes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-dcode.lisp

    r3865 r3898  
    158158      self)))
    159159
    160 ;Bring the generic function to the smallest possible size by removing
    161 ;any cached recomputable info.  Currently this means clearing out the
    162 ;combined methods from the dispatch table.
     160;;; Bring the generic function to the smallest possible size by removing
     161;;; any cached recomputable info.  Currently this means clearing out the
     162;;; combined methods from the dispatch table.
    163163
    164164(defun clear-gf-cache (gf)
     
    179179
    180180(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p)
    181   ; Grow the table associated with gf and insert table-entry as the value for
    182   ; wrapper.  Wrapper is a class-wrapper.  Assumes that it is not obsolete.
    183   (let* ((dt (if (standard-generic-function-p gf-or-cm)
     181  ;; Grow the table associated with gf and insert table-entry as the value for
     182  ;; wrapper.  Wrapper is a class-wrapper.  Assumes that it is not obsolete.
     183  (let* ((dt (if (generic-function-p gf-or-cm)
    184184               (%gf-dispatch-table gf-or-cm)
    185                (%combined-method-methods gf-or-cm)))  ; huh
     185               (%combined-method-methods gf-or-cm)))
    186186         (size (%gf-dispatch-table-size dt))
    187187         (new-size (if obsolete-wrappers-p
     
    191191    (if (> new-size *max-gf-dispatch-table-size*)
    192192      (progn
    193         (when (not (fixnump (%gf-dispatch-table-mask dt)))(bug "906")) ; cant be right that its so big
    194193        (setq new-dt (clear-gf-dispatch-table dt)
    195                    *gf-dt-ovf-cnt* (%i+ *gf-dt-ovf-cnt* 1))
    196         (when (not (fixnump (%gf-dispatch-table-mask new-dt)))(bug "903")))
     194                   *gf-dt-ovf-cnt* (%i+ *gf-dt-ovf-cnt* 1)))
    197195      (progn
    198196        (setq new-dt (make-gf-dispatch-table new-size))
     
    216214      (setf (%gf-dispatch-table-ref new-dt index) wrapper)
    217215      (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) table-entry))
    218     (if (standard-generic-function-p gf-or-cm)
     216    (if (generic-function-p gf-or-cm)
    219217      (setf (%gf-dispatch-table gf-or-cm) new-dt)
    220218      (setf (%combined-method-methods gf-or-cm) new-dt))))
     
    226224
    227225
    228 ; probably want to use alists vs. hash-tables initially
    229 
    230 
    231 ; only used if error - well not really
     226;;; probably want to use alists vs. hash-tables initially
     227
     228
     229;;; only used if error - well not really
    232230(defun collect-lexpr-args (args first &optional last)
    233231  (if (listp args)
     
    258256
    259257(defmacro %standard-instance-p (i)
    260   `(eq (typecode ,i) ,(target-arch-case
    261                        (:ppc32 ppc32::subtag-instance)
    262                        (:ppc64 ppc64::subtag-instance))))
     258  `(eq (typecode ,i) ,(type-keyword-code :instance)))
    263259
    264260
     
    280276             (or (and (typep arg 'macptr)
    281277                      (foreign-instance-class-wrapper arg))
     278                 (and (generic-function-p arg)
     279                      (gf.instance.class-wrapper arg))
    282280                 (let* ((class (class-of arg)))
    283281                   (or (%class.own-wrapper class)
     
    300298            (progn
    301299              (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
    302                 (if (or (neq table-wrapper (%unbound-marker-8))
     300                (if (or (neq table-wrapper (%unbound-marker))
    303301                        (eql 0 flag))
    304302                  (without-interrupts   ; why?
     
    307305              (setq index (+ 2 index)))))))))
    308306
    309 ; more PC - it it possible one needs to go round more than once? - seems unlikely
     307;;; more PC - it it possible one needs to go round more than once? -
     308;;; seems unlikely
    310309(defun %find-nth-arg-combined-method (dt arg args) 
    311310  (declare (optimize (speed 3)(safety 0)))
     
    314313             (or (and (typep arg 'macptr)
    315314                      (foreign-instance-class-wrapper arg))
     315                 (and (generic-function-p arg)
     316                      (gf.instance.class-wrapper arg))
    316317                 (let* ((class (class-of arg)))
    317318                   (or (%class.own-wrapper class)
     
    334335            (progn
    335336              (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
    336                 (if (or (neq table-wrapper (%unbound-marker-8))
     337                (if (or (neq table-wrapper (%unbound-marker))
    337338                        (eql 0 flag))
    338339                  (without-interrupts ; why?
     
    514515                               (ash 1 $lfbits-method-bit)))))))
    515516
     517(defglobal *generic-function-class-wrapper* nil)
     518(defglobal *standard-generic-function-class-wrapper* nil)
     519
    516520(defun generic-function-p (thing)
    517521  (and (typep thing 'function)
     
    521525             (logand bits (logior (ash 1 $lfbits-gfn-bit)
    522526                                  (ash 1 $lfbits-method-bit)))))
    523        (or (eq (%class.own-wrapper *generic-function-class*)
    524                (gf.instance.class-wrapper thing))
    525            (memq  *generic-function-class*
    526                   (%inited-class-cpl (class-of thing))))))
     527       (let* ((wrapper (gf.instance.class-wrapper thing)))
     528         ;; In practice, many generic-functions are standard-generic-functions.
     529         (or (eq *standard-generic-function-class-wrapper* wrapper)
     530             (eq *generic-function-class-wrapper* wrapper)
     531             (memq  *generic-function-class*
     532                  (%inited-class-cpl (class-of thing)))))))
    527533
    528534
     
    619625    (setf (%gf-dispatch-table-mask res) (%i- (%ilsr 1 size) 1)
    620626          (%gf-dispatch-table-argnum res) 0
    621           (%gf-dispatch-table-ref res size) (%unbound-marker-8))
     627          (%gf-dispatch-table-ref res size) (%unbound-marker))
    622628    res))
    623629
    624 ; I wanted this to be faster - I didn't
     630;;; I wanted this to be faster - I didn't
    625631(defun clear-gf-dispatch-table (dt)
    626632  (let ((i %gf-dispatch-table-first-data))
    627633    (dotimes (j (%gf-dispatch-table-size dt))
    628634      (declare (fixnum j))
    629       (setf (%svref dt i) nil               ; svref is for debugging - nil not 0 is right
     635      (setf (%svref dt i) nil
    630636            i (%i+ i 1)))
    631     (setf (%svref dt i) (%unbound-marker-8))  ; paranoia...
     637    (setf (%svref dt i) (%unbound-marker)) ; paranoia...
    632638    (setf (svref dt (%i+ 1 i)) nil))
    633639  dt)
     
    642648
    643649
    644 
    645 ;  Lap fever strikes again... is this still correct? - seems not - maybe ok now
     650;;; Searches for an empty slot in dt at the hash-index for wrapper.
     651;;; Returns nil if the table was full.
    646652(defun find-gf-dispatch-table-index (dt wrapper &optional skip-full-check?)
    647   ;searches for an empty slot in dt at the hash-index for wrapper.
    648   ;returns nil if the table was full.
    649653  (let ((contains-obsolete-wrappers-p nil)
    650654        (mask (%gf-dispatch-table-mask dt)))
     
    671675        (when (> count max-count)
    672676          (return-from find-gf-dispatch-table-index (values nil contains-obsolete-wrappers-p)))))
    673     (let* ((index (ash (logand mask (%wrapper-hash-index wrapper)) 1)) ; * 2 ??
     677    (let* ((index (ash (logand mask (%wrapper-hash-index wrapper)) 1))
    674678           (flag nil)
    675679           table-wrapper)     
     
    681685                     (neq 0 (%wrapper-hash-index table-wrapper)))
    682686           (setq index (%i+ index 2)))
    683          (if (eq (%unbound-marker-8) table-wrapper)
     687         (if (eq (%unbound-marker) table-wrapper)
    684688           (if flag
    685689             (return nil)         ; table full
     
    697701
    698702 
    699 ; This maximum is necessary because of the 32 bit arithmetic in
    700 ; find-gf-dispatch-table-index.
     703;;; This maximum is necessary because of the 32 bit arithmetic in
     704;;; find-gf-dispatch-table-index.
    701705(defparameter *max-gf-dispatch-table-size* (expt 2 16))
    702706(defvar *gf-dt-ovf-cnt* 0)              ; overflow count
     
    736740
    737741(defun %%no-applicable-method (gf args)
    738   ; do we really need this? - now we do
    739   ;(declare (dynamic-extent args)) ; today caller does the &rest
    740742  (if (listp args)
    741743    (apply #'no-applicable-method gf args)
    742744    (%apply-lexpr #'no-applicable-method gf args )))
    743745
    744 ; if obsolete-wrappers-p is true, will rehash instead of grow.
    745 ; It would be better to do the rehash in place, but I'm lazy today.
     746;;; if obsolete-wrappers-p is true, will rehash instead of grow.
     747;;; It would be better to do the rehash in place, but I'm lazy today.
    746748
    747749
     
    753755;;;;;;;;;;;;;;;;;;;;;;;;; generic-function dcode ;;;;;;;;;;;;;;;;;;;;;;;;;;;
    754756
    755 ;; Simple case for generic-functions with no specializers
    756 ;; Why anyone would want to do this I can't imagine.
     757;;; Simple case for generic-functions with no specializers
     758;;; Why anyone would want to do this I can't imagine.
    757759
    758760(defun %%0-arg-dcode (dispatch-table args) ; need to get gf from table
     
    803805;;;  arg is dispatch-table and argnum is in the dispatch table
    804806(defun %%nth-arg-dcode (dt args)
    805   ;(declare (dynamic-extent args))
    806807  (if (listp args)
    807808    (let* ((args-len (list-length args))
     
    817818      (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args)))
    818819        (%apply-lexpr-tail-wise method args)))))
    819 
    820 
    821 
    822 
    823820
    824821
     
    903900  (setf (gethash key *combined-methods*) value))
    904901
    905 ;; Some statistics on the hash table above
     902;;; Some statistics on the hash table above
    906903(defvar *returned-combined-methods* 0)
    907904(defvar *consed-combined-methods* 0)
    908905
    909 ;; Assumes methods are already sorted if cpls is nil
     906;;; Assumes methods are already sorted if cpls is nil
    910907(defun make-standard-combined-method (methods cpls gf &optional
    911908                                              (ok-if-no-primaries (null methods)))
     
    921918
    922919
    923 ; Initialized below after the functions exist.
     920;;; Initialized below after the functions exist.
    924921(defvar *clos-initialization-functions* nil)
    925922
    926 ; Returns NIL if all keywords allowed, or a vector of the allowable ones.
     923;;; Returns NIL if all keywords allowed, or a vector of the allowable ones.
    927924(defun compute-allowable-keywords-vector (gf methods)
    928925  (setq gf (combined-method-gf gf))
     
    951948          (apply #'vector keys))))))
    952949
    953 ; The aux arg is used by keyword checking for %call-next-method-with-args - it is?
     950
    954951(defun make-keyword-checking-combined-method (gf combined-method keyvect)
    955952  (let* ((bits (inner-lfun-bits gf))
     
    960957     (vector key-index keyvect combined-method)
    961958     #'%%check-keywords)))
    962 ; ok
    963 
    964 ; #(keyvect key-index combined-method) in atemp1 - actually key-index keyvect today
     959
    965960
    966961
     
    11851180      (unless (null primaries)            ; return NIL if no applicable primary methods
    11861181        (when (and arounds (not (next-method-bit-p (car (last arounds)))))
    1187           ; Arounds don't call-next-method, can't get to befores, afters, or primaries
     1182          ;; Arounds don't call-next-method, can't get to befores,
     1183          ;; afters, or primaries
    11881184          (setq primaries arounds
    11891185                arounds nil
     
    12061202
    12071203
    1208 ; ok
    12091204
    12101205(defun %invalid-method-error (method format-string &rest format-args)
     
    12141209  (apply #'error format-string args))
    12151210
    1216 ; ok
    12171211
    12181212
     
    12231217    gf))
    12241218
    1225 (defun nth-arg-dcode-too-few-args (gf-or-cm)
    1226   (signal-program-error "Too few args to: ~s" (combined-method-gf gf-or-cm)))
    12271219
    12281220(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args)
     
    12311223    (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper)))
    12321224
    1233 ; ok
    12341225
    12351226(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional
     
    12371228                                                    argnum args gf-or-cm))
    12381229                                              (wrapper (arg-wrapper arg)))
    1239   ; Here when we can't find the method in the dispatch table.
    1240   ; Compute it and add it to the table.  This code will remain in Lisp.
     1230  ;; Here when we can't find the method in the dispatch table.
     1231  ;; Compute it and add it to the table.  This code will remain in Lisp.
    12411232  (multiple-value-bind (combined-method sub-dispatch?)
    12421233                       (compute-nth-arg-combined-method
     
    12581249      combined-method)))
    12591250
    1260 ;; Returns (values combined-method sub-dispatch?)
    1261 ;; If sub-dispatch? is true, need to compute a combined-method on the
    1262 ;; next arg.
     1251;;; Returns (values combined-method sub-dispatch?)
     1252;;; If sub-dispatch? is true, need to compute a combined-method on the
     1253;;; next arg.
    12631254(defun compute-nth-arg-combined-method (gf methods argnum args &optional
    12641255                                           (wrapper (arg-wrapper
     
    12711262         applicable-methods eql-methods specializers specializer sub-dispatch?)
    12721263    (dolist (method methods)
    1273       ;(require-type method 'standard-method)   ; for debugging.
     1264      ;;(require-type method 'standard-method)   ; for debugging.
    12741265      (setq specializers (nthcdr argnum (%method.specializers method))
    12751266            specializer (%car specializers))
     
    13321323
    13331324
    1334 ;; This needs to be updated to use a linear search in a vector changing to
    1335 ;; a hash table when the number of entries crosses some threshold.
     1325;;; This needs to be updated to use a linear search in a vector changing to
     1326;;; a hash table when the number of entries crosses some threshold.
    13361327(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
    13371328                                             (method-combination *standard-method-combination*))
     
    14101401        default-method))))
    14111402
    1412 ; ok
    1413 
    1414 
    1415 
    1416 (DEFun %%assq-combined-method-dcode (stuff args)
     1403
     1404
     1405
     1406(defun %%assq-combined-method-dcode (stuff args)
    14171407  ;; stuff is (argnum eql-method-list . default-method)
    14181408  ;(declare (dynamic-extent args))
     
    14581448
    14591449
    1460 ; Assumes the two methods have the same number of specializers and that
    1461 ; each specializer of each method is in the corresponding element of cpls
    1462 ; (e.g. cpls is a list of the cpl's for the classes of args for which both
    1463 ; method1 & method2 are applicable.
     1450;;; Assumes the two methods have the same number of specializers and
     1451;;; that each specializer of each method is in the corresponding
     1452;;; element of cpls (e.g. cpls is a list of the cpl's for the classes
     1453;;; of args for which both method1 & method2 are applicable.
    14641454(defun %method< (method1 method2 cpls)
    14651455  (let ((s1s (%method.specializers method1))
     
    15961586             (dynamic-extent cell-2))   
    15971587    (if (listp car-meths)
    1598       (progn
    1599         (%%before-and-after-combined-method-dcode magic))
     1588      (%%before-and-after-combined-method-dcode magic)
    16001589      (progn       
    16011590        (if (not (cdr methods))
     
    18251814
    18261815
    1827 ;; This makes a consed version of the magic first arg to a method.
    1828 ;; Called when someone closes over the magic arg. (i.e. does (george #'call-next-method))
     1816;;; This makes a consed version of the magic first arg to a method.
     1817;;; Called when someone closes over the magic arg. (i.e. does (george
     1818;;; #'call-next-method))
    18291819
    18301820(defun %cons-magic-next-method-arg (magic)
Note: See TracChangeset for help on using the changeset viewer.