Different, more compact structure for lexical environments.

src/CHANGELOG

@@ -1,158 +1,12 @@
-ECL 0.9g
+ECL 0.9h
 ========
 
-* Platforms:
+* Design:
 
- - Fixed the broken port for MacOSX. It should work with any release >= 10.2
+ - Simplified the structure of the frame stack, removing redundant fields.
 
- - Based on version 6.5 of Boehm-Weiser garbage collector, which fixes some
-   problems related to the OSX port.
-
- - The latest version of Mingw32's GCC is broken. It silently ignores pathnames
-   which end in '/'.  The include options in ECL have been modified to take
-   this into account but this intrinsic bug of Mingw might influence ECL's
-   behavior in some other unexpected ways.
-
- - The configuration in Solaris should now proceed with the flag
-   --enable-slow-conf.
-
-* Foreign function interface (FFI):
-
- - Added nickname UFFI for FFI package; functions ALLOCATE-FOREIGN-STRING,
-   WITH-FOREIGN-STRING, WITH-FOREIGN-STRINGS, and FOREIGN-STRING-LENGTH are now
-   exported. (M. Pasternacki)
-
- - Ecl now accepts :CSTRING UFFI primitive type. (M. Pasternacki)
-
- - DEF-FOREIGN-VAR rewritten to make variables visible from other files and to
-   dereference also arrays and pointers. (M. Pasternacki)
-
- - When creating a C-STRING, characters after the fill pointer are discarded,
-   according to people's expectations.
-
-* Compiler changes:
-
- - Generated C functions now have readable names corresponding to appropriate
-   Lisp function names (M. Pasternacki)
-
- - ECL now compiles with the free Microsoft Visual C++ Toolkit
-   2003. Instructions are provided on how to do it.
-
- - Unless SI:*KEEP-DOCUMENTATION* = NIL, the documentation of functions is
-   stored in the compiled files.
-
- - COMPILE-FILE now honors the value of :OUTPUT-FILE given by the user, even if
-   they do no have the usual extension (.fas). Furthermore, LOAD will now try
-   to load files with strange extensions (.fas, .fasl, etc) as binary files and
-   only if this fails, use the source-file loader.
-
- - .LSP/.LISP are now recognized lisp source extensions.
-
- - We now provide inline expansions for all logical operators.
-
- - We have changed the syntax both for function proclamantions and for inline
-   expansions in sysfun.lsp Additionally, the checks for functions having side
-   effects have been improved and inline expansions are now stored with a
-   special-purpose structure INLINE-INFO.
-
-* Errors fixed:
-
- - Now .o files compiled with :SYSTEM-P T with dash in filename load
-   correctly. (M. Pasternacki)
-
- - Incorrectly loaded files are now unloaded without falling into infinite
-   loop.  (M. Pasternacki)
-
- - When ECASE or CTYPECASE signal a TYPE-EROR the TYPE-ERROR-DATUM is the value
-   that originated the error.
-
- - FDEFINITION did not signal a type error when passed things like '(SETF A B).
-
- - FUNCTION-LAMBDA-EXPRESSION does not fail, but does nothing useful, when
-   passed a generic function.
-
- - Trying to execute an instance object that is not a generic function does no
-   longer crashes ECL.
-
- - When signalling a READER-ERROR, the field reader-error-stream was not bound.
-
- - The random number generator assumed 32-bit integers.
-
- - ext:run-program looks into *standard-input/output* and *error-output* for handle
-   duplication also under Win32.
-
- - FEtype_error_index() had format arguments in wrong order (M. Goffioul).
-
- - In the LOOP macro, variables are initialized with values of their type, no
-   longer producing code like (LET ((C NIL)) (DECLARE (CHARACTER C)) ...)
-
- - The compiler now advertises itself with PROVIDE so that issuing (REQUIRE
-   'CMP) twice does not cause the compiler to be loaded twice.
-
- - Fix error message of interpreted FFI:CLINES form (M. Goffioul).
-
- - Remove obsolete C::BUILD-ECL documentation (M. Goffioul).
-
- - The conversion from ratio to float works now even if the numerator/denominator
-   are themselves too large to fit a float.
-
- - Fixnums and short-floats were compared using the "float" C type. This led to
-   loss of precision and caused
-	 (= (1+ (ceiling (rational -3.781832e7))) -3.781832e7) => T
-
- - Keyword arguments in a type defined with DEFTYPE, for which a default value
-   is not given, default to '*. Also the DEFTYPE form are enclosed in a block
-   with the name of the type.
-
- - The syntax of #\: can now be changed.
-
- - Adjusting displaced bit-vectors failed to take the displace-offset into
-   account.
-
- - Variable SI::*GC-VERBOSE* controls whether ECL emits messages when FASL
-   libraries are garbage colleced.
-
- - Values of EQL specializers are now evaluated in the lexical environment
-   in which the DEFMETHOD is enclosed. This makes it now possible to write
-	(defmethod foo (x) (defmethod bar ((f (eql x)))))
-
- - Fixes in the C code to comply with gcc 4.0.
-
-* ANSI compatibility:
-
- - Several functions that signaled type-errors did not set the right values
-   on the field TYPE-ERROR-EXPECTED-TYPE. We now use the following types:
-	* valid function names => (SATISFIES EXT:VALID-FUNCTION-NAME-P)
-	* proper list	       => PROPER-LIST = (OR (CONS T PROPER-LIST) NULL)
-	* positive fixnum      => (INTEGER 0 MOST-POSITIVE-FIXNUM)
-	* nonnegative integer  => (INTEGER 0 *)
-	* index in a seq       => (INTEGER 0 L) where L is (1- (length sequence))
-
- - (COMPLEX *) is now recognized as valid type identifier by subtypep.
-
- - TYPE-OF now returns more precise type names, so that if (TYPE-OF x) = t1 and
-   (TYPEP x t2) = T then (SUBTYPEP t1 t2) = T.
-
- - MAKE-PATHNAME now signals ordinary errors when the arguments do not have
-   the required type, but signals a file error when it finds something like
-   a wrong directory (i.e. '(:ABSOLUTE :UP)).
-
- - Pathnames which contain :BACK in the directory, now print as unreadable
-   objects, instead of signaling an error when printing.
-
- - Declaration names cannot be used to define new type names and viceversa.
-
- - #\Space has constituent trait "invalid".
-
- - DEFINE-SETF-EXPANDER encloses the form in an implicit block with the name of
-   the SETF function.
-
-* New features:
-
- - Added function si:rmdir (M. Pasternacki)
-
- - There are now specialized arrays for 32 or 64 bits data, depending on the
-   size of words in the platform.
+ - Reworked the structure of the lexical environment to accelerate access to
+   variables.
 
 ;;; Local Variables: ***
 ;;; mode:text ***

src/c/compiler.d

@@ -380,18 +380,20 @@ c_new_env(struct cl_compiler_env *new_c_env, cl_object env)
 		return;
 	}
 	ENV->lexical_level = 1;
-	for (env = @revappend(env, Cnil); !Null(env); env = CDDR(env))
+	for (env = @revappend(env, Cnil); !Null(env); env = CDR(env))
 	{
-		cl_object tag = CADR(env);
-		cl_object what = CAR(env);
-		if (tag == @':tag')
+		cl_object record = CAR(env);
+		cl_object record0 = CAR(record);
+		cl_object record1 = CDR(record);
+		if (SYMBOLP(record0)) {
+			c_register_var(record0, FALSE, TRUE);
+		} else if (!FIXNUMP(record0)) {
+			c_register_function(record1);
+		} else if (record1 == MAKE_FIXNUM(0)) {
 			c_register_tags(Cnil);
-		else if (tag == @':block')
-			c_register_block(CAR(what));
-		else if (tag == @':function')
-			c_register_function(CAR(what));
-		else
-			c_register_var(tag, FALSE, TRUE);
+		} else {
+			c_register_block(record1);
+		}
 	}
 }
 

src/c/interpreter.d

@@ -161,27 +161,27 @@ cl_stack_push_list(cl_object list)
 static void
 bind_var(register cl_object var, register cl_object val)
 {
-	cl_env.lex_env = CONS(var, CONS(val, cl_env.lex_env));
+	cl_env.lex_env = CONS(CONS(var, val), cl_env.lex_env);
 }
 
 static void
 bind_function(cl_object name, cl_object fun)
 {
-	cl_env.lex_env = CONS(@':function', CONS(CONS(name, fun), cl_env.lex_env));
+	cl_env.lex_env = CONS(CONS(fun, name), cl_env.lex_env);
 }
 
 static cl_object
 bind_tagbody()
 {
 	cl_object id = new_frame_id();
-	cl_env.lex_env = CONS(@':tag', CONS(id, cl_env.lex_env));
+	cl_env.lex_env = CONS(CONS(id, MAKE_FIXNUM(0)), cl_env.lex_env);
 	return id;
 }
 
 static void
 bind_block(cl_object name, cl_object id)
 {
-	cl_env.lex_env = CONS(@':block', CONS(CONS(name, id), cl_env.lex_env));
+	cl_env.lex_env = CONS(CONS(id, name), cl_env.lex_env);
 }
 
 static void
@@ -191,22 +191,18 @@ bind_special(register cl_object var, register cl_object val)
 }
 
 static cl_object
-search_local(register int s) {
+ecl_lex_env_get_record(register int s) {
 	cl_object x;
-	for (x = cl_env.lex_env; s-- > 0 && !Null(x); x = CDDR(x));
+	for (x = cl_env.lex_env; s-- > 0; x = CDR(x));
 	if (Null(x))
 		FEerror("Internal error: local not found.", 0);
-	return CADR(x);
+	return CAR(x);
 }
 
-static void
-setq_local(register int s, register cl_object v) {
-	cl_object x;
-	for (x = cl_env.lex_env; s-- > 0 && !Null(x); x = CDDR(x));
-	if (Null(x))
-		FEerror("Internal error: local ~S not found.", 1, s);
-	CADR(x) = v;
-}
+#define ecl_lex_env_get_var(x) CDR(ecl_lex_env_get_record(x))
+#define ecl_lex_env_set_var(x,v) (CDR(ecl_lex_env_get_record(x)) = (v))
+#define ecl_lex_env_get_fun(x) CAR(ecl_lex_env_get_record(x))
+#define ecl_lex_env_get_tag(x) CAR(ecl_lex_env_get_record(x))
 
 /* -------------------- LAMBDA FUNCTIONS -------------------- */
 
@@ -641,9 +637,9 @@ interpret_labels(cl_object bytecodes, cl_opcode *vector) {
 
 	/* 2) Update the closures so that all functions can call each other */
 	for (i=0, l=cl_env.lex_env; i<nfun; i++) {
-		cl_object record = CADR(l);
-		CDR(record) = close_around(CDR(record), cl_env.lex_env);
-		l = CDDR(l);
+		cl_object record = CAR(l);
+		CAR(record) = close_around(CAR(record), cl_env.lex_env);
+		l = CDR(l);
 	}
 	return vector;
 }
@@ -668,7 +664,7 @@ interpret_msetq(cl_object bytecodes, cl_opcode *vector)
 		cl_fixnum var = GET_OPARG(vector);
 		value = (i < NVALUES) ? VALUES(i) : Cnil;
 		if (var >= 0)
-			setq_local(var, value);
+			ecl_lex_env_set_var(var, value);
 		else {
 			cl_object name = bytecodes->bytecodes.data[-1-var];
 			if (name->symbol.stype == stp_constant)
@@ -735,7 +731,7 @@ interpret(cl_object bytecodes, void *pc) {
 	*/
 	case OP_VAR: {
 		int lex_env_index = GET_OPARG(vector);
-		reg0 = search_local(lex_env_index);
+		reg0 = ecl_lex_env_get_var(lex_env_index);
 		break;
 	}
 
@@ -761,7 +757,7 @@ interpret(cl_object bytecodes, void *pc) {
 	*/
 	case OP_PUSHV: {
 		int lex_env_index = GET_OPARG(vector);
-		cl_stack_push(search_local(lex_env_index));
+		cl_stack_push(ecl_lex_env_get_var(lex_env_index));
 		break;
 	}
 
@@ -885,8 +881,8 @@ interpret(cl_object bytecodes, void *pc) {
 	*/
 	case OP_LFUNCTION: {
 		int lex_env_index = GET_OPARG(vector);
-		cl_object fun_record = search_local(lex_env_index);
-		reg0 = CDR(fun_record);
+		cl_object fun_record = ecl_lex_env_get_record(lex_env_index);
+		reg0 = CAR(fun_record);
 		break;
 	}
 
@@ -916,7 +912,7 @@ interpret(cl_object bytecodes, void *pc) {
 		purposes.
 	*/
 	case OP_GO: {
-		cl_object id = search_local(GET_OPARG(vector));
+		cl_object id = ecl_lex_env_get_tag(GET_OPARG(vector));
 		cl_object tag_name = GET_DATA(vector, bytecodes);
 		cl_go(id, tag_name);
 		break;
@@ -927,9 +923,9 @@ interpret(cl_object bytecodes, void *pc) {
 	*/
 	case OP_RETURN: {
 		int lex_env_index = GET_OPARG(vector);
-		cl_object block_record = search_local(lex_env_index);
-		cl_object block_name = CAR(block_record);
-		cl_object id = CDR(block_record);
+		cl_object block_record = ecl_lex_env_get_record(lex_env_index);
+		cl_object id = CAR(block_record);
+		cl_object block_name = CDR(block_record);
 		cl_return_from(id, block_name);
 		break;
 	}
@@ -993,7 +989,7 @@ interpret(cl_object bytecodes, void *pc) {
 	case OP_UNBIND: {
 		cl_index n = GET_OPARG(vector);
 		while (n--)
-			cl_env.lex_env = CDDR(cl_env.lex_env);
+			cl_env.lex_env = CDR(cl_env.lex_env);
 		break;
 	}
 	/* OP_UNBINDS	n{arg}
@@ -1057,7 +1053,7 @@ interpret(cl_object bytecodes, void *pc) {
 	*/
 	case OP_SETQ: {
 		int lex_env_index = GET_OPARG(vector);
-		setq_local(lex_env_index, reg0);
+		ecl_lex_env_set_var(lex_env_index, reg0);
 		break;
 	}
 	case OP_SETQS: {
@@ -1069,7 +1065,7 @@ interpret(cl_object bytecodes, void *pc) {
 	}
 	case OP_PSETQ: {
 		int lex_env_index = GET_OPARG(vector);
-		setq_local(lex_env_index, cl_stack_pop());
+		ecl_lex_env_set_var(lex_env_index, cl_stack_pop());
 		break;
 	}
 	case OP_PSETQS: {
@@ -1184,7 +1180,7 @@ interpret(cl_object bytecodes, void *pc) {
 		break;
 	}
 	case OP_EXIT_TAGBODY:
-		cl_env.lex_env = CDDR(cl_env.frs_top->frs_lex);
+		cl_env.lex_env = CDR(cl_env.frs_top->frs_lex);
 		frs_pop();
 		cl_stack_pop();
 	case OP_NIL:

src/h/stacks.h

@@ -147,19 +147,18 @@ extern ecl_frame_ptr _frs_push(register cl_object val);
  * LEXICAL ENVIRONMENT STACK
  *****************************/
 /*
-
-cl_env.lex_env ------> ( tag0 value0 tag1 value1 ... )
-
-	tag:		variable-name (symbol)
-	value:		variable-value (any lisp object)
-
-	tag:		:function
-	value:		(function-name . function-object)
-
-	tag:		:block
-	value:		(block-name . frame-id)
-
-*/
+ * A lexical environment is a list of pairs, each one containing either
+ * a variable definition, a tagbody or block tag, or a local function
+ * definition.
+ *
+ *	lex_env ---> ( { record }* )
+ *	record = variable | function | block_tag | tagbody_tag
+ *
+ *	variable = ( var_name[symbol] . value )
+ *	function = ( function[bytecodes] . fun_name[symbol] )
+ *	block_tag = ( tag[fixnum] . block_name[symbol] )
+ *	tagbody_tag = ( tag[fixnum] . 0 )
+ */
 
 /*********************************
  * HIGH LEVEL CONTROL STRUCTURES *

src/lsp/top.lsp

@@ -636,15 +636,17 @@ file.  When the saved image is invoked, it will start the redefined top-level."
 	(*print-pretty* t)
 	(*print-readably* nil)
 	(functions) (blocks) (variables))
-    (do* ((env *break-env* (cddr env))
-	  (type (first env) (first env))
-	  (data (second env) (second env)))
-	((endp env))
-      (case type
-	(:function (push (car data) functions))
-	(:block (push (car data) blocks))
-	(:tag)
-	(otherwise (setq variables (list* type data variables)))))
+    (dolist (record *break-env*)
+      (let* ((record0 (car record))
+	     (record1 (cdr record)))
+	(cond ((symbolp record0)
+	       (setq variables (list* record0 record1 variables)))
+	      ((not (fixnump record0))
+	       (push record1 functions))
+	      ((symbolp record1)
+	       (push record1 blocks))
+	      (t
+	       ))))
     (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions)
     (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks)
     (format t "Local variables: ~:[~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~