Changeset 9365


Ignore:
Timestamp:
May 6, 2008, 12:14:27 AM (11 years ago)
Author:
gz
Message:

New :UNIQUE-DCODE optional feature:

if ccl is built with

(rebuild-ccl :optional-features '(:unique-dcode))

then each generic function will have its own unique copy
of its dcode, whose name is a list (dcode-name gf-name).

This feature is not recommend for real use (for one thing,
it's known to break gf tracing), but may be helpful for
profiling.

Location:
branches/working-0711/ccl
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/PPC/ppc-def.lisp

    r6178 r9365  
    12321232  (bctr))
    12331233
     1234(defun %copy-function (proto)
     1235  (let* ((uvsize (uvsize proto))
     1236         (newv (allocate-typed-vector :function uvsize)))
     1237    (declare (fixnum uvsize))
     1238    (%copy-gvector-to-gvector proto 0 newv 0 uvsize)))
    12341239
    12351240(defun replace-function-code (target-fn proto-fn)
  • branches/working-0711/ccl/level-0/X86/x86-def.lisp

    r6553 r9365  
    112112      (declare (fixnum k) (list imms))
    113113      (setf (%svref newv k) (car imms)))))
     114
     115(defun %copy-function (proto)
     116  (let* ((protov (%function-to-function-vector proto))
     117         (code-words (%function-code-words proto))
     118         (uvsize (uvsize protov))
     119         (newv (allocate-typed-vector :function uvsize)))
     120    (declare (fixnum code-words uvsize))
     121    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
     122    (loop for k fixnum from code-words below uvsize
     123          do (setf (%svref newv k) (%svref protov k)))
     124    (%function-vector-to-function newv)))
    114125
    115126(defun replace-function-code (target proto)
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r9360 r9365  
    564564           spec)))
    565565
     566(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil
     567  "If true, each gf will get its own unique copy of its dcode.  Not recommended for
     568   real use (for one thing, it's known to break gf tracing), but may be helpful for
     569   profiling")
     570
     571
    566572(let* ((class-wrapper-random-state (make-random-state))
    567573       (class-wrapper-random-state-lock (make-lock)))
     
    10541060
    10551061
    1056            
    1057  
    10581062(defvar *writer-method-function-proto*
    10591063  #'(lambda (new instance)
    10601064      (set-slot-value instance 'x new)))
    10611065
    1062 
     1066(defun dcode-for-gf (gf dcode)
     1067  (if *uniquify-dcode*
     1068    (let ((new-dcode (%copy-function dcode)))
     1069      (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf)))
     1070      new-dcode)
     1071    dcode))
    10631072
    10641073(defun compute-dcode (gf &optional dt)
     
    10961105                               #'%%1st-two-arg-dcode
    10971106                               #'%%1st-arg-dcode))                           
    1098                              #'%%1st-arg-dcode)))))
     1107                           #'%%1st-arg-dcode)))))
    10991108        (setq multi-method-index
    11001109              (if multi-method-index
     
    11201129                  (setf (cdr encapsulated-dcode-cons) dcode))
    11211130                (progn
    1122                   (setf (%gf-dcode gf) dcode)
     1131                  (setf (%gf-dcode gf) (dcode-for-gf gf dcode))
    11231132                  (replace-function-code gf proto))))))
    11241133        (values dcode multi-method-index)))))
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r9352 r9365  
    14501450
    14511451  (replace-function-code instance *gf-proto*)
    1452   (setf (gf.dcode instance) #'%%0-arg-dcode))
     1452  (setf (gf.dcode instance) (dcode-for-gf instance #'%%0-arg-dcode)))
    14531453       
    14541454                                       
     
    18011801
    18021802(defun optimize-dispatching-for-gf (gf)
    1803   (let* ((dcode (%gf-dcode gf)))
    1804     (when (or (eq dcode #'%%one-arg-dcode)
    1805               (eq dcode #'%%nth-arg-dcode))
     1803  (let* ((dcode (%gf-dcode gf))
     1804         (name (function-name dcode)))
     1805    (when (or (eq name '%%one-arg-dcode)
     1806              (eq name '%%nth-arg-dcode))
    18061807      (let ((methods (generic-function-methods gf)))
    18071808        (when (and methods (null (cdr methods)))
     
    19621963                         (setf (%svref dt %gf-dispatch-table-first-data) class
    19631964                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
    1964                                (gf.dcode f) #'singleton-reader-dcode)))
     1965                               (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode))))
    19651966                      ((dolist (other (cdr alist) t)
    19661967                         (unless (eq (cdr other) loc)
     
    19751976                                (%svref dt (1+ %gf-dispatch-table-first-data))
    19761977                                loc
    1977                                 (gf.dcode f) #'reader-constant-location-dcode))
     1978                                (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode)))
    19781979                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
    19791980                          ;; Lots of classes, all subclasses of a single class
     
    19831984                                loc
    19841985                                (gf.dcode f)
    1985                                 #'reader-constant-location-inherited-from-single-class-dcode))
     1986                                (dcode-for-gf f #'reader-constant-location-inherited-from-single-class-dcode)))
    19861987                         (t
    19871988                          ;; Multple classes.  We should probably check
     
    19921993                                loc
    19931994                                (gf.dcode f)
    1994                                 #'reader-constant-location-inherited-from-multiple-classes-dcode))))
     1995                                (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode)))))
    19951996                      (t
    19961997                       ;; Multiple classes; the slot's location varies.
     
    19981999                             alist
    19992000                             
    2000                              (gf.dcode f) #'reader-variable-location-dcode)))))))))))
     2001                             (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode))))))))))))
    20012002
    20022003;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
     
    20372038                          (logbitp $lfbits-aok-bit bits))))
    20382039    (setf (%gf-dcode gf)
    2039           (cond ((and (eql nreq 1) (null other-args?))
    2040                  #'%%one-arg-eql-method-hack-dcode)
    2041                 ((and (eql nreq 2) (null other-args?))
    2042                  #'%%1st-two-arg-eql-method-hack-dcode)
    2043                 (t
    2044                  #'%%1st-arg-eql-method-hack-dcode)))))
    2045 
     2040          (dcode-for-gf gf
     2041                        (cond ((and (eql nreq 1) (null other-args?))
     2042                               #'%%one-arg-eql-method-hack-dcode)
     2043                              ((and (eql nreq 2) (null other-args?))
     2044                               #'%%1st-two-arg-eql-method-hack-dcode)
     2045                              (t
     2046                               #'%%1st-arg-eql-method-hack-dcode))))))
    20462047 
    20472048 
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r9165 r9365  
    457457    (:darwinx8664 "darwinx8664")))
    458458
    459 (defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait))
     459(defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait :unique-dcode))
    460460(defvar *build-time-optional-features* nil)
    461461
Note: See TracChangeset for help on using the changeset viewer.