mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-08 02:10:36 -08:00
Code Issues Projects Releases Packages Wiki Activity

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.

Browse source
This commit is contained in:
jjgarcia 2005-09-19 09:31:01 +00:00
parent 5bc2e8ede3
commit 2d5bb45946
11 changed files with 60 additions and 263 deletions
Download patch file Download diff file Expand all files Collapse all files

18
src/CHANGELOG
View file

@ -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

5
src/c/compiler.d
View file

@ -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
*/

2
src/c/reference.d
View file

@ -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);
}

2
src/c/symbols_list.h
View file

@ -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}};

2
src/c/symbols_list2.h
View file

@ -1548,6 +1548,8 @@ cl_symbols[] = {
{SYS_ "LOAD-BINARY","si_load_binary"},
#endif
{SYS_ "*CODE-WALKER*",NULL},
/* Tag for end of list */
{NULL,NULL}};

4
src/clos/boot.lsp
View file

@ -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
;;;

6
src/clos/change.lsp
View file

@ -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
;;;

3
src/clos/load.lsp.in
View file

@ -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"

2
src/clos/macros.lsp
View file

@ -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"))

263
src/clos/method.lsp
View file

@ -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))

16
src/clos/standard.lsp
View file

@ -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