Changeset 3898 for trunk/ccl/level1/l1dcode.lisp
 Timestamp:
 Mar 26, 2006, 3:23:00 AM (15 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/ccl/level1/l1dcode.lisp
r3865 r3898 158 158 self))) 159 159 160 ; Bring the generic function to the smallest possible size by removing161 ; any cached recomputable info. Currently this means clearing out the162 ; 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. 163 163 164 164 (defun cleargfcache (gf) … … 179 179 180 180 (defun growgfdispatchtable (gforcm wrapper tableentry &optional obsoletewrappersp) 181 ; Grow the table associated with gf and insert tableentry as the value for182 ; wrapper. Wrapper is a classwrapper. Assumes that it is not obsolete.183 (let* ((dt (if ( standardgenericfunctionp gforcm)181 ;; Grow the table associated with gf and insert tableentry as the value for 182 ;; wrapper. Wrapper is a classwrapper. Assumes that it is not obsolete. 183 (let* ((dt (if (genericfunctionp gforcm) 184 184 (%gfdispatchtable gforcm) 185 (%combinedmethodmethods gforcm))) ; huh185 (%combinedmethodmethods gforcm))) 186 186 (size (%gfdispatchtablesize dt)) 187 187 (newsize (if obsoletewrappersp … … 191 191 (if (> newsize *maxgfdispatchtablesize*) 192 192 (progn 193 (when (not (fixnump (%gfdispatchtablemask dt)))(bug "906")) ; cant be right that its so big194 193 (setq newdt (cleargfdispatchtable dt) 195 *gfdtovfcnt* (%i+ *gfdtovfcnt* 1)) 196 (when (not (fixnump (%gfdispatchtablemask newdt)))(bug "903"))) 194 *gfdtovfcnt* (%i+ *gfdtovfcnt* 1))) 197 195 (progn 198 196 (setq newdt (makegfdispatchtable newsize)) … … 216 214 (setf (%gfdispatchtableref newdt index) wrapper) 217 215 (setf (%gfdispatchtableref newdt (%i+ index 1)) tableentry)) 218 (if ( standardgenericfunctionp gforcm)216 (if (genericfunctionp gforcm) 219 217 (setf (%gfdispatchtable gforcm) newdt) 220 218 (setf (%combinedmethodmethods gforcm) newdt)))) … … 226 224 227 225 228 ; probably want to use alists vs. hashtables initially229 230 231 ; only used if error  well not really226 ;;; probably want to use alists vs. hashtables initially 227 228 229 ;;; only used if error  well not really 232 230 (defun collectlexprargs (args first &optional last) 233 231 (if (listp args) … … 258 256 259 257 (defmacro %standardinstancep (i) 260 `(eq (typecode ,i) ,(targetarchcase 261 (:ppc32 ppc32::subtaginstance) 262 (:ppc64 ppc64::subtaginstance)))) 258 `(eq (typecode ,i) ,(typekeywordcode :instance))) 263 259 264 260 … … 280 276 (or (and (typep arg 'macptr) 281 277 (foreigninstanceclasswrapper arg)) 278 (and (genericfunctionp arg) 279 (gf.instance.classwrapper arg)) 282 280 (let* ((class (classof arg))) 283 281 (or (%class.ownwrapper class) … … 300 298 (progn 301 299 (when (null (%gfdispatchtableref dt (the fixnum (1+ index)))) 302 (if (or (neq tablewrapper (%unboundmarker 8))300 (if (or (neq tablewrapper (%unboundmarker)) 303 301 (eql 0 flag)) 304 302 (withoutinterrupts ; why? … … 307 305 (setq index (+ 2 index))))))))) 308 306 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 310 309 (defun %findnthargcombinedmethod (dt arg args) 311 310 (declare (optimize (speed 3)(safety 0))) … … 314 313 (or (and (typep arg 'macptr) 315 314 (foreigninstanceclasswrapper arg)) 315 (and (genericfunctionp arg) 316 (gf.instance.classwrapper arg)) 316 317 (let* ((class (classof arg))) 317 318 (or (%class.ownwrapper class) … … 334 335 (progn 335 336 (when (null (%gfdispatchtableref dt (the fixnum (1+ index)))) 336 (if (or (neq tablewrapper (%unboundmarker 8))337 (if (or (neq tablewrapper (%unboundmarker)) 337 338 (eql 0 flag)) 338 339 (withoutinterrupts ; why? … … 514 515 (ash 1 $lfbitsmethodbit))))))) 515 516 517 (defglobal *genericfunctionclasswrapper* nil) 518 (defglobal *standardgenericfunctionclasswrapper* nil) 519 516 520 (defun genericfunctionp (thing) 517 521 (and (typep thing 'function) … … 521 525 (logand bits (logior (ash 1 $lfbitsgfnbit) 522 526 (ash 1 $lfbitsmethodbit))))) 523 (or (eq (%class.ownwrapper *genericfunctionclass*) 524 (gf.instance.classwrapper thing)) 525 (memq *genericfunctionclass* 526 (%initedclasscpl (classof thing)))))) 527 (let* ((wrapper (gf.instance.classwrapper thing))) 528 ;; In practice, many genericfunctions are standardgenericfunctions. 529 (or (eq *standardgenericfunctionclasswrapper* wrapper) 530 (eq *genericfunctionclasswrapper* wrapper) 531 (memq *genericfunctionclass* 532 (%initedclasscpl (classof thing))))))) 527 533 528 534 … … 619 625 (setf (%gfdispatchtablemask res) (%i (%ilsr 1 size) 1) 620 626 (%gfdispatchtableargnum res) 0 621 (%gfdispatchtableref res size) (%unboundmarker 8))627 (%gfdispatchtableref res size) (%unboundmarker)) 622 628 res)) 623 629 624 ; I wanted this to be faster  I didn't630 ;;; I wanted this to be faster  I didn't 625 631 (defun cleargfdispatchtable (dt) 626 632 (let ((i %gfdispatchtablefirstdata)) 627 633 (dotimes (j (%gfdispatchtablesize dt)) 628 634 (declare (fixnum j)) 629 (setf (%svref dt i) nil ; svref is for debugging  nil not 0 is right635 (setf (%svref dt i) nil 630 636 i (%i+ i 1))) 631 (setf (%svref dt i) (%unboundmarker 8)); paranoia...637 (setf (%svref dt i) (%unboundmarker)) ; paranoia... 632 638 (setf (svref dt (%i+ 1 i)) nil)) 633 639 dt) … … 642 648 643 649 644 645 ; Lap fever strikes again... is this still correct?  seems not  maybe ok now650 ;;; Searches for an empty slot in dt at the hashindex for wrapper. 651 ;;; Returns nil if the table was full. 646 652 (defun findgfdispatchtableindex (dt wrapper &optional skipfullcheck?) 647 ;searches for an empty slot in dt at the hashindex for wrapper.648 ;returns nil if the table was full.649 653 (let ((containsobsoletewrappersp nil) 650 654 (mask (%gfdispatchtablemask dt))) … … 671 675 (when (> count maxcount) 672 676 (returnfrom findgfdispatchtableindex (values nil containsobsoletewrappersp))))) 673 (let* ((index (ash (logand mask (%wrapperhashindex wrapper)) 1)) ; * 2 ??677 (let* ((index (ash (logand mask (%wrapperhashindex wrapper)) 1)) 674 678 (flag nil) 675 679 tablewrapper) … … 681 685 (neq 0 (%wrapperhashindex tablewrapper))) 682 686 (setq index (%i+ index 2))) 683 (if (eq (%unboundmarker 8) tablewrapper)687 (if (eq (%unboundmarker) tablewrapper) 684 688 (if flag 685 689 (return nil) ; table full … … 697 701 698 702 699 ; This maximum is necessary because of the 32 bit arithmetic in700 ; findgfdispatchtableindex.703 ;;; This maximum is necessary because of the 32 bit arithmetic in 704 ;;; findgfdispatchtableindex. 701 705 (defparameter *maxgfdispatchtablesize* (expt 2 16)) 702 706 (defvar *gfdtovfcnt* 0) ; overflow count … … 736 740 737 741 (defun %%noapplicablemethod (gf args) 738 ; do we really need this?  now we do739 ;(declare (dynamicextent args)) ; today caller does the &rest740 742 (if (listp args) 741 743 (apply #'noapplicablemethod gf args) 742 744 (%applylexpr #'noapplicablemethod gf args ))) 743 745 744 ; if obsoletewrappersp 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 obsoletewrappersp is true, will rehash instead of grow. 747 ;;; It would be better to do the rehash in place, but I'm lazy today. 746 748 747 749 … … 753 755 ;;;;;;;;;;;;;;;;;;;;;;;;; genericfunction dcode ;;;;;;;;;;;;;;;;;;;;;;;;;;; 754 756 755 ;; Simple case for genericfunctions with no specializers756 ;; Why anyone would want to do this I can't imagine.757 ;;; Simple case for genericfunctions with no specializers 758 ;;; Why anyone would want to do this I can't imagine. 757 759 758 760 (defun %%0argdcode (dispatchtable args) ; need to get gf from table … … 803 805 ;;; arg is dispatchtable and argnum is in the dispatch table 804 806 (defun %%nthargdcode (dt args) 805 ;(declare (dynamicextent args))806 807 (if (listp args) 807 808 (let* ((argslen (listlength args)) … … 817 818 (let ((method (%findnthargcombinedmethod dt (%lexprref args argslen argnum) args))) 818 819 (%applylexprtailwise method args))))) 819 820 821 822 823 820 824 821 … … 903 900 (setf (gethash key *combinedmethods*) value)) 904 901 905 ;; Some statistics on the hash table above902 ;;; Some statistics on the hash table above 906 903 (defvar *returnedcombinedmethods* 0) 907 904 (defvar *consedcombinedmethods* 0) 908 905 909 ;; Assumes methods are already sorted if cpls is nil906 ;;; Assumes methods are already sorted if cpls is nil 910 907 (defun makestandardcombinedmethod (methods cpls gf &optional 911 908 (okifnoprimaries (null methods))) … … 921 918 922 919 923 ; Initialized below after the functions exist.920 ;;; Initialized below after the functions exist. 924 921 (defvar *closinitializationfunctions* nil) 925 922 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. 927 924 (defun computeallowablekeywordsvector (gf methods) 928 925 (setq gf (combinedmethodgf gf)) … … 951 948 (apply #'vector keys)))))) 952 949 953 ; The aux arg is used by keyword checking for %callnextmethodwithargs  it is? 950 954 951 (defun makekeywordcheckingcombinedmethod (gf combinedmethod keyvect) 955 952 (let* ((bits (innerlfunbits gf)) … … 960 957 (vector keyindex keyvect combinedmethod) 961 958 #'%%checkkeywords))) 962 ; ok 963 964 ; #(keyvect keyindex combinedmethod) in atemp1  actually keyindex keyvect today 959 965 960 966 961 … … 1185 1180 (unless (null primaries) ; return NIL if no applicable primary methods 1186 1181 (when (and arounds (not (nextmethodbitp (car (last arounds))))) 1187 ; Arounds don't callnextmethod, can't get to befores, afters, or primaries 1182 ;; Arounds don't callnextmethod, can't get to befores, 1183 ;; afters, or primaries 1188 1184 (setq primaries arounds 1189 1185 arounds nil … … 1206 1202 1207 1203 1208 ; ok1209 1204 1210 1205 (defun %invalidmethoderror (method formatstring &rest formatargs) … … 1214 1209 (apply #'error formatstring args)) 1215 1210 1216 ; ok1217 1211 1218 1212 … … 1223 1217 gf)) 1224 1218 1225 (defun nthargdcodetoofewargs (gforcm)1226 (signalprogramerror "Too few args to: ~s" (combinedmethodgf gforcm)))1227 1219 1228 1220 (defun nthargcombinedmethodtrap0 (gforcm table wrapper args) … … 1231 1223 (nthargcombinedmethodtrap gforcm table argnum args arg wrapper))) 1232 1224 1233 ; ok1234 1225 1235 1226 (defun nthargcombinedmethodtrap (gforcm table argnum args &optional … … 1237 1228 argnum args gforcm)) 1238 1229 (wrapper (argwrapper 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. 1241 1232 (multiplevaluebind (combinedmethod subdispatch?) 1242 1233 (computenthargcombinedmethod … … 1258 1249 combinedmethod))) 1259 1250 1260 ;; Returns (values combinedmethod subdispatch?)1261 ;; If subdispatch? is true, need to compute a combinedmethod on the1262 ;; next arg.1251 ;;; Returns (values combinedmethod subdispatch?) 1252 ;;; If subdispatch? is true, need to compute a combinedmethod on the 1253 ;;; next arg. 1263 1254 (defun computenthargcombinedmethod (gf methods argnum args &optional 1264 1255 (wrapper (argwrapper … … 1271 1262 applicablemethods eqlmethods specializers specializer subdispatch?) 1272 1263 (dolist (method methods) 1273 ; (requiretype method 'standardmethod) ; for debugging.1264 ;;(requiretype method 'standardmethod) ; for debugging. 1274 1265 (setq specializers (nthcdr argnum (%method.specializers method)) 1275 1266 specializer (%car specializers)) … … 1332 1323 1333 1324 1334 ;; This needs to be updated to use a linear search in a vector changing to1335 ;; 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. 1336 1327 (defun makeeqlcombinedmethod (eqlmethods methods cpls gf argnum subdispatch? &optional 1337 1328 (methodcombination *standardmethodcombination*)) … … 1410 1401 defaultmethod)))) 1411 1402 1412 ; ok 1413 1414 1415 1416 (DEFun %%assqcombinedmethoddcode (stuff args) 1403 1404 1405 1406 (defun %%assqcombinedmethoddcode (stuff args) 1417 1407 ;; stuff is (argnum eqlmethodlist . defaultmethod) 1418 1408 ;(declare (dynamicextent args)) … … 1458 1448 1459 1449 1460 ; Assumes the two methods have the same number of specializers and that1461 ; each specializer of each method is in the corresponding element of cpls1462 ; (e.g. cpls is a list of the cpl's for the classes of args for which both1463 ; 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. 1464 1454 (defun %method< (method1 method2 cpls) 1465 1455 (let ((s1s (%method.specializers method1)) … … 1596 1586 (dynamicextent cell2)) 1597 1587 (if (listp carmeths) 1598 (progn 1599 (%%beforeandaftercombinedmethoddcode magic)) 1588 (%%beforeandaftercombinedmethoddcode magic) 1600 1589 (progn 1601 1590 (if (not (cdr methods)) … … 1825 1814 1826 1815 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 #'callnextmethod)) 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 ;;; #'callnextmethod)) 1829 1819 1830 1820 (defun %consmagicnextmethodarg (magic)
Note: See TracChangeset
for help on using the changeset viewer.