Keep a SETF location object in the compiled code, to speed up the lookup of #'(SETF fname) functions. Also, store a closure in that object for the cases in which we fmakunbound it.

src/c/assignment.d

@@ -28,6 +28,21 @@ cl_set(cl_object var, cl_object val)
 	return1(ECL_SETQ(env, var, val));
 }
 
+static cl_object
+unbound_setf_function_error(cl_narg narg, ...)
+{
+	const cl_env_ptr the_env = ecl_process_env();
+        cl_object name = the_env->function->cclosure.env;
+	FEundefined_function(cl_list(2, @'setf', name));
+}
+
+static cl_object
+make_setf_function_error(cl_object name)
+{
+	return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error,
+				    name, Cnil);
+}
+
 cl_object
 ecl_setf_definition(cl_object sym, cl_object createp)
 {
@@ -36,7 +51,8 @@ ecl_setf_definition(cl_object sym, cl_object createp)
         ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) {
                 pair = ecl_gethash_safe(sym, cl_core.setf_definitions, Cnil);
 		if (Null(pair) && !Null(createp)) {
-			pair = ecl_cons(createp, sym);
+			createp = make_setf_function_error(sym);
+			pair = ecl_cons(createp, Cnil);
 			ecl_sethash(sym, cl_core.setf_definitions, pair);
 		}
         } ECL_WITH_GLOBAL_ENV_RDLOCK_END;
@@ -101,6 +117,7 @@ ecl_rem_setf_definition(cl_object sym)
 	} else {
 		cl_object pair = ecl_setf_definition(sym, def);
 		ECL_RPLACA(pair, def);
+		ECL_RPLACD(pair, sym);
 	}
 	@(return def)
 @)

src/c/reference.d

@@ -16,6 +16,7 @@
 */
 
 #include <ecl/ecl.h>
+#include <ecl/internal.h>
 #include <ecl/ecl-inl.h>
 
 /*
@@ -62,7 +63,7 @@ cl_fboundp(cl_object fname)
 				cl_object pair;
 				sym = CAR(sym);
 				pair = ecl_setf_definition(sym, Cnil);
-				@(return ecl_car(pair))
+				@(return ecl_cdr(pair))
 			}
 		}
 	}
@@ -77,26 +78,26 @@ ecl_fdefinition(cl_object fun)
 
 	if (t == t_symbol) {
 		output = SYM_FUN(fun);
-		if (output == Cnil)
+		unlikely_if (output == Cnil)
 			FEundefined_function(fun);
-		if (fun->symbol.stype & (stp_macro | stp_special_form))
+		unlikely_if (fun->symbol.stype & (stp_macro | stp_special_form))
 			FEundefined_function(fun);
-	} else if (Null(fun)) {
+	} else unlikely_if (Null(fun)) {
 		FEundefined_function(fun);
 	} else if (t == t_list) {
 		cl_object sym = CDR(fun);
-		if (!CONSP(sym))
+		unlikely_if (!CONSP(sym))
 			FEinvalid_function_name(fun);
 		if (CAR(fun) == @'setf') {
-			if (CDR(sym) != Cnil)
+			unlikely_if (CDR(sym) != Cnil)
 				FEinvalid_function_name(fun);
 			sym = CAR(sym);
-			if (type_of(sym) != t_symbol)
+			unlikely_if (type_of(sym) != t_symbol)
 				FEinvalid_function_name(fun);
 			output = ecl_setf_definition(sym, Cnil);
-			output = ecl_car(output);
-			if (Null(output))
+			unlikely_if (Null(ecl_cdr(output)))
 				FEundefined_function(fun);
+			output = ECL_CONS_CAR(output);
 		} else if (CAR(fun) == @'lambda') {
 			return si_make_lambda(Cnil, sym);
 		} else if (CAR(fun) == @'ext::lambda-block') {

src/cmp/cmpglobals.lsp

@@ -248,6 +248,7 @@ lines are inserted, but the order is preserved")
 (defvar *load-time-values* nil)		; holds { ( vv-index form ) }*,
 ;;;  where each vv-index should be given an object before
 ;;;  defining the current function during loading process.
+(defvar *setf-definitions* nil)         ; C forms to find out (SETF fname) locations
 
 (defvar *use-static-constants-p* nil)   ; T/NIL flag to determine whether one may
                                         ; generate lisp constant values as C structs
@@ -326,6 +327,7 @@ be deleted if they have been opened with LoadLibrary.")
     (*next-cfun* 0)
     (*last-label* 0)
     (*load-objects* (make-hash-table :size 128 :test #'equal))
+    (*setf-definitions* nil)
     (*make-forms* nil)
     (*static-constants* nil)
     (*permanent-objects* nil)

src/cmp/cmpspecial.lsp

@@ -123,13 +123,40 @@
 	(push fun *local-funs*))))
 
 (defun wt-fdefinition (fun-name)
-  (let ((vv (add-object fun-name)))
-    (if (and (symbolp fun-name)
-	     (or (not (safe-compile))
-		 (and (eql (symbol-package fun-name) (find-package "CL"))
-		      (fboundp fun-name) (functionp (fdefinition fun-name)))))
-	(wt "(" vv "->symbol.gfdef)")
-	(wt "ecl_fdefinition(" vv ")"))))
+  (let* ((name (si::function-block-name fun-name))
+	 (package (symbol-package name))
+	 (safe (or (not (safe-compile))
+		   (and (or (eq package (find-package "CL"))
+			    (eq package (find-package "CLOS"))
+			    (eq package (find-package "SI")))
+			(fboundp fun-name)
+			(functionp (fdefinition fun-name))))))
+    (if (eq name fun-name)
+	;; #'symbol
+	(let ((vv (add-symbol name)))
+	  (if safe
+	      (wt "(" vv "->symbol.gfdef)")
+	      (wt "ecl_fdefinition(" vv ")")))
+	;; #'(SETF symbol)
+	(if safe
+	    #+(or)
+	    (let ((set-loc (assoc name *setf-definitions*)))
+	      (unless set-loc
+		(let* ((setf-vv (data-empty-loc))
+		       (name-vv (add-symbol name))
+		       (setf-form-vv (add-object fun-name)))
+		  (setf set-loc (list name setf-vv name-vv setf-form-vv))
+		  (push set-loc *setf-definitions*)))
+	      (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")"))
+	    (let ((set-loc (assoc name *setf-definitions*)))
+	      (unless set-loc
+		(let* ((setf-vv (data-empty-loc))
+		       (name-vv (add-symbol name)))
+		  (setf set-loc (list name setf-vv name-vv))
+		  (push set-loc *setf-definitions*)))
+	      (wt "ECL_CONS_CAR(" (second set-loc) ")"))
+	    (let ((vv (add-symbol fun-name)))
+	      (wt "ecl_fdefinition(" vv ")"))))))
 
 (defun environment-accessor (fun)
   (let* ((env-var (env-var-name *env-lvl*))

src/cmp/cmptop.lsp

@@ -173,6 +173,8 @@
 
     (wt-nl "VVtemp = Cblock->cblock.temp_data;")
 
+    (wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
+
     ;; Type propagation phase
 
     (when *do-type-propagation*
@@ -232,6 +234,22 @@
 	   (lisp-name (third l)))
       (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)"
 	      "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
+  #+(or)
+  (wt-nl-h "static cl_object ECL_SETF_DEFINITION(cl_object setf_vv, cl_object setf_form) {
+cl_object f1 = ecl_fdefinition(setf_form);
+cl_object f2 = ECL_CONS_CAR(setf_vv);
+if (f1 != f2) {
+cl_print(1,f1);
+cl_print(1,f2);
+cl_print(1,setf_form);
+FEundefined_function(setf_form);
+}
+return f2;
+}
+")
+  (wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ")
+  (loop for (name setf-vv name-vv) in *setf-definitions*
+     do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",Ct);"))
 
   (wt-nl-h "#ifdef __cplusplus")
   (wt-nl-h "}")