From 2d5bb459469522952cb2bf1236a6fb82f9f4e30d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 19 Sep 2005 09:31:01 +0000 Subject: [PATCH] Replaced the code walker with some hooks in the bytecodes compiler and use this for the analysis of method functions. The optimizations of SLOT-VALUE references are removed, since they are buggy. --- src/CHANGELOG | 18 +++ src/c/compiler.d | 5 + src/c/reference.d | 2 + src/c/symbols_list.h | 2 + src/c/symbols_list2.h | 2 + src/clos/boot.lsp | 4 - src/clos/change.lsp | 6 - src/clos/load.lsp.in | 3 +- src/clos/macros.lsp | 2 +- src/clos/method.lsp | 263 +++++------------------------------------- src/clos/standard.lsp | 16 --- 11 files changed, 60 insertions(+), 263 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 6bde6ffc6..7055457bd 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -11,6 +11,24 @@ ECL 0.9h - New hash routine, similar to SBCL's one, faster and leading to fewer collisions between similar strings. + - Method combinations do not longer rely on a hash table of precomputed + effective methods. That method required a structural analysis of the forms + generated by the method combinations, which is plain slower than generating + the effective method as either a closure (in most cases) or as bytecodes + (for the most complex declarative forms). + + - CALL-NEXT-METHOD and NEXT-METHOD-P are now implemented in a simpler way, + without relying on the code walker (which is a damm buggy piece of code). + + - Formerly, the body of methods was walked through, replacing slot access with + the indices of the slots in the object structure. This is plain wrong + because the structure of a class may change. Such aggressive optimizations + may be reimplemented in a future in the compiler, but only when the user + asks for them. + + - The code walker is no longer needed and has been removed from the core. + It will be available in the contributed packages. + * Visible changes: - The code for handling command line options has been redesigned. Now multiple diff --git a/src/c/compiler.d b/src/c/compiler.d index ec95f1123..96f7479c2 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1868,6 +1868,7 @@ c_values(cl_object args, int flags) { static int compile_form(cl_object stmt, int flags) { + cl_object code_walker = SYM_VAL(@'si::*code-walker*'); compiler_record *l; cl_object function; bool push = flags & FLAG_PUSH; @@ -1875,6 +1876,10 @@ compile_form(cl_object stmt, int flags) { /* FIXME! We should protect this region with error handling */ BEGIN: + if (code_walker != OBJNULL) { + stmt = funcall(3, SYM_VAL(@'si::*code-walker*'), stmt, + CONS(ENV->variables, ENV->macros)); + } /* * First try with variable references and quoted constants */ diff --git a/src/c/reference.d b/src/c/reference.d index ff1c641ca..15f68831a 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -91,6 +91,8 @@ ecl_fdefinition(cl_object fun) FEundefined_function(fun); } else if (CAR(fun) == @'lambda') { return si_make_lambda(Cnil, sym); + } else if (CAR(fun) == @'ext::lambda-block') { + return si_make_lambda(CAR(sym), CDR(sym)); } else { FEinvalid_function_name(fun); } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1af45c7c5..7c0db9342 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1548,6 +1548,8 @@ cl_symbols[] = { {SYS_ "LOAD-BINARY", SI_ORDINARY, si_load_binary, 3, OBJNULL}, #endif +{SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index f80cafb60..ce38d8405 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1548,6 +1548,8 @@ cl_symbols[] = { {SYS_ "LOAD-BINARY","si_load_binary"}, #endif +{SYS_ "*CODE-WALKER*",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 5993fc283..60195b935 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -93,10 +93,6 @@ (setf (slot-value class 'prototype) (allocate-instance class))) (slot-value class 'prototype)) -(defmethod OPTIMIZE-SLOT-VALUE ((prototype t) form) form) - -(defmethod OPTIMIZE-SET-SLOT-VALUE ((prototype t) form) form) - ;;; ---------------------------------------------------------------------- ;;; SLOTS READING AND WRITING ;;; diff --git a/src/clos/change.lsp b/src/clos/change.lsp index 068de93a2..7d40e895c 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -13,12 +13,6 @@ (defclass forward-referenced-class (class) ()) -;;; ---------------------------------------------------------------------- - -(defmethod OPTIMIZE-SLOT-VALUE ((class class) form) form) - -(defmethod OPTIMIZE-SET-SLOT-VALUE ((class class) form) form) - ;;; ---------------------------------------------------------------------- ;;; INSTANCE UPDATE PROTOCOL ;;; diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 3e0e8a768..6bb97d6f7 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -1,8 +1,7 @@ ;;; @configure_input@ (defconstant +clos-module-files+ -'("src:clos;walk.lsp" - "src:clos;macros.lsp" +'("src:clos;macros.lsp" "src:clos;kernel.lsp" "src:clos;method.lsp" "src:clos;slot.lsp" diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index 8769f6f9a..4337988d9 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -8,7 +8,7 @@ ;;;; See file '../Copyright' for full details. (defpackage "CLOS" - (:use "WALKER" "CL") + (:use "CL") (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "COMPUTE-EFFECTIVE-METHOD" "SIMPLE-PROGRAM-ERROR")) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index b3f616894..42bade69a 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -123,15 +123,10 @@ (aux-bindings ()) ; Suffice to say that &aux is one of ; damndest things to have put in a ; language. - (slots (mapcar #'list required-parameters)) - ; records for each class: - ; - slot-index-table - ; - slot-indexes for each slot - ; See optimize-standard-instance-access. (plist ())) (multiple-value-bind (walked-lambda call-next-method-p save-original-args next-method-p-p) - (walk-method-lambda method-lambda required-parameters env slots) + (walk-method-lambda method-lambda required-parameters env) ;; Scan the lambda list to determine whether this method ;; takes &mumble arguments. If it does, we set applyp and @@ -161,9 +156,6 @@ (sys::find-declarations (cdddr walked-lambda) t) (declare (ignore ignore)) - (when (some #'cdr slots) ; there are optimized slot accesses - (setq walked-lambda-body - (add-index-binding walked-lambda-body slots))) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p 'T plist))) @@ -190,111 +182,34 @@ documentation plist))))))) -(defun walk-method-lambda (method-lambda required-parameters env slots) +(defun walk-method-lambda (method-lambda required-parameters env) (declare (si::c-local)) - (let ((call-next-method-p nil);flag indicating that call-next-method - ;should be in the method definition - (next-method-p-p nil) ;flag indicating that next-method-p - ;should be in the method definition - (save-original-args nil);flag indicating whether or not the - ;original arguments to the method - ;must be preserved. This happens - ;for two reasons: - ; - the method takes &mumble args, - ; so one of the lexical functions - ; might be used in a default value - ; form - ; - call-next-method is used without - ; arguments at least once in the - ; body of the method - (closurep nil) ;flag indicating whether #'call-next-method - ;was seen in the code - ) - (flet ((walk-function (form context env) - (cond ((not (eq context ':EVAL)) form) - ((not (listp form)) form) - ((eq (car form) 'CALL-NEXT-METHOD) - (setq call-next-method-p 'T - save-original-args (not (cdr form))) - form) - ((eq (car form) 'NEXT-METHOD-P) - (setq next-method-p-p 'T) - form) - ((and (eq (car form) 'FUNCTION) - (case (second form) - (CALL-NEXT-METHOD - (setq call-next-method-p 'T - closurep 'T - save-original-args 'T) - form) - (NEXT-METHOD-P - (setq next-method-p-p 'T) - form) - (t nil)))) - ((and (eq (car form) 'SLOT-VALUE) - (symbolp (second form)) - (constantp (third form))) - (multiple-value-bind (ignore prototype) - (can-optimize-access (second form) env) - (if prototype - (optimize-slot-value prototype form) - form))) - ;; does not work for (push x (slot-value y 's)) - ;; and similia, since push is turned into - ;; (|(setf slot-value)| (cons (slot-value y 's) x) x 's) - ((eq (car form) 'SETF) - (if (cdddr form) - (do* ((setf-list (cdr form) (cddr setf-list)) - (instance-access) - (value) - (result)) - ((null setf-list) - (cons 'PROGN (nreverse result))) - (setq instance-access (car setf-list) - value (second setf-list)) - (push - (if (and instance-access - (listp instance-access) - (eq (car instance-access) - 'SLOT-VALUE) - (symbolp (second instance-access)) - (constantp (third instance-access))) - (multiple-value-bind (ignore prototype) - (can-optimize-access - (second instance-access) env) - (let ((new-form - (list 'SETF instance-access - value))) - (if prototype - (optimize-set-slot-value prototype - new-form) - new-form))) - (list 'SETF instance-access value)) - result)) - (if (and (cdr form) - (second form) - (listp (second form)) - (eq (caadr form) 'SLOT-VALUE) - (symbolp (cadadr form)) - (constantp (third (second form)))) - (multiple-value-bind (ignore class) - (can-optimize-access (cadadr form) env) - (if class - (optimize-set-slot-value class form) - form)) - form))) - ((eq (car form) 'STANDARD-INSTANCE-ACCESS) - (multiple-value-bind (parameter prototype) - (can-optimize-access (second form) env) - (if prototype - (optimize-standard-instance-access - (class-of prototype) parameter form slots) - form))) - (t form)))) - (values (walk-form method-lambda env #'walk-function) - (if closurep 'FUNCTION call-next-method-p) - save-original-args - next-method-p-p)))) + (let ((call-next-method-p nil) + (next-method-p-p nil) + (save-original-args-p nil)) + (flet ((code-walker (form env) + (unless (atom form) + (let ((name (first form))) + (case name + (CALL-NEXT-METHOD + (setf call-next-method-p + (or call-next-method-p T)) + (unless (rest form) + (setf save-original-args-p t))) + (NEXT-METHOD-P + (setf next-method-p-p t)) + (FUNCTION + (when (eq (second form) 'CALL-NEXT-METHOD) + (setf save-original-args-p t + call-next-method-p 'FUNCTION)) + (when (eq (second form) 'NEXT-METHOD-P) + (setf next-method-p-p 'FUNCTION)))))) + form)) + (let ((si::*code-walker* #'code-walker)) + (coerce method-lambda 'function))) + (values method-lambda call-next-method-p + save-original-args-p + next-method-p-p))) (defun add-lexical-functions-to-method-lambda (walked-declarations walked-lambda-body @@ -626,125 +541,5 @@ `(let ((,temp ,instance-form)) (symbol-macrolet ,accessors ,@body)))) - -;;; ---------------------------------------------------------------------- -;;; optimizers - -(defun can-optimize-access (var env) - (declare (si::c-local)) - ;; (values required-parameter class) - (let ((required-parameter? - (or (third (variable-declaration 'VARIABLE-REBINDING var env)) - var)) - (class-prototype nil)) - (when required-parameter? - (let ((class (find-class (variable-class required-parameter? env) 'NIL))) - (when class - (setf class-prototype (class-prototype class))))) - (values required-parameter? class-prototype))) - - -(defun optimize-standard-instance-access (class parameter form slots) - (declare (si::c-local)) - ;; Returns an optimized form corresponding to FORM. - ;; SLOTS is a list of: - ;; (parameter [(class . class-index-table) {(slot-name . slot-index)}+]) - ;; parameters of the same class share the cdr of such list. - ;; - (let* ((instance (second form)) - (slot-name (reduce-constant (third form))) - (new (fourth form)) - (entry (assoc parameter slots :test #'eq)) - slot) - (unless entry - (error "Can't optimize instance access. Report this as a bug.")) - (setq slot (find slot-name (slot-value class 'SLOTS) - :key #'slot-definition-name)) - (if (and slot (eq :INSTANCE (slot-definition-allocation slot))) - (let* (slot-entry slot-index) - (unless (cdr entry) - ;; there is just one index-table for each different class - (let ((class-slot-info (find class slots :key #'caadr :test #'eq))) - (setf (cdr entry) - (if class-slot-info - (cdr class-slot-info) - ;; create variable for index-table - (list (cons class (gensym))))))) - (setq slot-entry (assoc slot-name (cddr entry) :test #'eq)) - (if slot-entry - (setq slot-index (cdr slot-entry)) - (push (cons slot-name (setq slot-index (gensym))) - (cddr entry))) - (if new - `(si:instance-set ,instance ,slot-index ,new) - `(the ,(slot-definition-type slot) - (si:instance-ref-safe ,instance ,slot-index)))) - ;; dont'optimize shared slots - (if new - `(standard-instance-set ,new ,instance ',slot-name) - `(standard-instance-get ,instance ',slot-name))))) - -;(defun get-slot-definition-type (class slot) -; (slot-definition-type (find slot (slot-value class 'SLOTS) :key #'slot-definition-name))) - -(defun signal-slot-unbound (instance slot-name) - (declare (si::c-local)) - (slot-unbound (si:instance-class instance) instance slot-name)) - -(defun add-index-binding (method-body isl) - (declare (si::c-local)) - (let* (class-index-bindings - slot-index-bindings - slot-index-declarations) - - ;; don't forget setf! Chicca - (setf class-index-bindings - (dolist (entry isl (nreverse class-index-bindings)) - ;; check if the entry provides the information needed! Chicca - (when (cdr entry) - (unless (assoc (cdadr entry) class-index-bindings :test #'eq) - (push `(,(cdadr entry) - (let ((class (si:instance-class ,(first entry)))) - (declare (type standard-class class)) - (slot-index-table class))) - class-index-bindings))))) - - ;; don't forget setf! Chicca - (setf slot-index-bindings - (dolist (entry isl (nreverse slot-index-bindings)) - (dolist (slot-entry (cddr entry)) - (push `(,(cdr slot-entry) - (slot-index ',(first slot-entry) ,(cdadr entry))) - slot-index-bindings) - (push `(fixnum ,(cdr slot-entry)) - slot-index-declarations)))) - - `((let ,class-index-bindings - (let ,slot-index-bindings - (declare . ,slot-index-declarations) - . ,method-body))))) - - ;;; Force the compiler into optimizing use of gethash inside methods: -(setf (symbol-function 'SLOT-INDEX) (symbol-function 'GETHASH)) - -(defun reduce-constant (old) - (let ((new (eval old))) - (if (eq new old) - new - (if (constantp new) - (reduce-constant new) - new)))) - -;;; ---------------------------------------------------------------------- -;;; walker - -;;; Inform the walker of the kind of declarations to consider: - -(pushnew 'TYPE *variable-declarations*) -(pushnew 'VARIABLE-REBINDING *variable-declarations*) - -(defun variable-class (var env) - (second (variable-declaration 'TYPE var env))) - -;;; ---------------------------------------------------------------------- +(setf (symbol-function 'SLOT-INDEX) (symbol-function 'GETHASH)) \ No newline at end of file diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index d2a84dd7b..53296d354 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -588,22 +588,6 @@ because it contains a reference to the undefined class~% ~A" 'SETF val)) val)) -;;; ---------------------------------------------------------------------- -;;; optimizers - -(defmethod OPTIMIZE-SLOT-VALUE ((prototype standard-object) form) - (let* ((instance (second form)) - (slot-name (third form))) - `(standard-instance-access ,instance - ',(reduce-constant slot-name) . ,(cdddr form)))) - -(defmethod OPTIMIZE-SET-SLOT-VALUE ((prototype standard-object) form) - (let* ((instance (cadadr form)) - (slot-name (caddr (second form))) - (new-value (third form))) - `(standard-instance-access ,instance - ',(reduce-constant slot-name) ,new-value))) - ;;; ---------------------------------------------------------------------- ;;; Methods