Remove unused blocks

src/CHANGELOG

@@ -16,6 +16,20 @@ ECL 0.9k:
    to [[device:[//hostname]]/]... The reason is that this allows proper
    parsing of Unix pathnames such as "//usr/".
 
+ - In interpreted functions, blocks are only created when used. The current
+   algorithm for detecting unused blocks is inefficient, with a performance
+   penalty 2^{# unused blocks}, but this seems to pay off when running the
+   interpreted code, due to decreased consing
+	> (defun foo () )         
+	FOO
+	> (time (dotimes (i 100000) (foo)))
+	real time : 0.045 secs
+	run time  : 0.048 secs
+	gc count  : 1 times
+	consed    : 160 bytes
+   Formerly, this would cons 3200192 bytes.
+
+
 * CLOS:
 
  - When caching generic function calls, ECL now uses a thread-local hash table

src/c/compiler.d

@@ -346,7 +346,7 @@ asm_op2c(register int code, register cl_object o) {
 static void
 c_register_block(cl_object name)
 {
-	ENV->variables = CONS(cl_list(2, @':block', name), ENV->variables);
+	ENV->variables = CONS(cl_list(3, @':block', name, Cnil), ENV->variables);
 }
 
 static void
@@ -358,7 +358,7 @@ c_register_tags(cl_object all_tags)
 static void
 c_register_function(cl_object name)
 {
-	ENV->variables = CONS(cl_list(2, @':function', name), ENV->variables);
+	ENV->variables = CONS(cl_list(3, @':function', name, Cnil), ENV->variables);
 	ENV->macros = CONS(cl_list(2, name, @'function'), ENV->macros);
 }
 
@@ -468,8 +468,11 @@ c_tag_ref(cl_object the_tag, cl_object the_type)
 			n++;
 		} else if (type == @':block' || type == @':function') {
 			/* We compare with EQUAL, because of (SETF fname) */
-			if (type == the_type && ecl_equal(name, the_tag))
+			if (type == the_type && ecl_equal(name, the_tag)) {
+				/* Mark as used */
+				CADDR(record) = Ct;
 				return MAKE_FIXNUM(n);
+			}
 			n++;
 		} else if (Null(name)) {
 			n++;
@@ -692,29 +695,42 @@ maybe_reg0(int flags) {
 */
 
 static int
-c_block(cl_object body, int flags) {
+c_block(cl_object body, int old_flags) {
+	struct cl_compiler_env old_env;
 	cl_object name = pop(&body);
-	cl_object old_env = ENV->variables;
-	cl_index labelz;
+	cl_object block_record;
+	cl_index labelz, pc;
+	int flags;
 
 	if (!SYMBOLP(name))
 		FEprogram_error("BLOCK: Not a valid block name, ~S", 1, name);
 
-	flags = maybe_values_or_reg0(flags);
+	old_env = *ENV;
+	pc = current_pc();
+
+	flags = maybe_values_or_reg0(old_flags);
 	c_register_block(name);
-	if (Null(name))
+	block_record = CAR(ENV->variables);
+	if (Null(name)) {
 		labelz = asm_jmp(OP_DO);
-	else {
+	} else {
 		asm_op(OP_BLOCK);
 		asm_c(name);
 		labelz = current_pc();
 		asm_arg(0);
 	}
 	compile_body(body, flags);
-	asm_op(OP_EXIT_FRAME);
-	asm_complete(Null(name)? OP_DO : 0, labelz);
-	ENV->variables = old_env;
-	return flags;
+	if (CADDR(block_record) == Cnil) {
+		/* Block unused. We remove the enclosing OP_BLOCK/OP_DO */
+		*ENV = old_env;
+		set_pc(pc);
+		return compile_body(body, old_flags);
+	} else {
+		asm_op(OP_EXIT_FRAME);
+		asm_complete(Null(name)? OP_DO : 0, labelz);
+		ENV->variables = old_env.variables;
+		return flags;
+	}
 }
 
 /*
@@ -2116,14 +2132,14 @@ si_process_lambda(cl_object lambda)
  * VALUES(5) = allow-other-keys			; flag &allow-other-keys
  * VALUES(6) = (N aux1 init1 ... )		; auxiliary variables
  *
- * 1°) The prefix "N" is an integer value denoting the number of
+ * 1°) The prefix "N" is an integer value denoting the number of
  * variables which are declared within this section of the lambda
  * list.
  *
- * 2°) The INIT* arguments are lisp forms which are evaluated when
+ * 2°) The INIT* arguments are lisp forms which are evaluated when
  * no value is provided.
  *
- * 3°) The FLAG* arguments is the name of a variable which holds a
+ * 3°) The FLAG* arguments is the name of a variable which holds a
  * boolean value in case an optional or keyword argument was
  * provided. If it is NIL, no such variable exists.
  */

src/c/interpreter.d

@@ -341,7 +341,6 @@ ecl_apply_lambda(cl_narg narg, cl_object fun)
 	/* Establish bindings */
 	lambda_bind(narg, fun, args);
 
-	/* If it is a named lambda, set a block for RETURN-FROM */
 	VALUES(0) = Cnil;
 	NVALUES = 0;
 	name = fun->bytecodes.name;

src/lsp/config.lsp.in

@@ -24,7 +24,7 @@ Returns, as a string, the location of the machine on which ECL runs."
 (defun lisp-implementation-version ()
   "Args:()
 Returns the version of your ECL as a string."
-  "@PACKAGE_VERSION@ (CVS 2008-01-14 22:35)")
+  "@PACKAGE_VERSION@ (CVS 2008-01-26 14:29)")
 
 (defun machine-type ()
   "Args: ()