From a1bc92b05c1d79ee0e6b69edafab47a189cc57dc Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 15 Feb 2009 12:05:56 +0100 Subject: [PATCH] Changed the way closures are invoked, to make them similar to generic functions and bytecodes --- src/c/eval.d | 4 ++-- src/c/hash.d | 2 +- src/c/interpreter.d | 2 +- src/cmp/cmpcall.lsp | 5 ++++- src/cmp/cmpdefs.lsp | 1 + src/cmp/cmptop.lsp | 6 +++++- 6 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/c/eval.d b/src/c/eval.d index 253814377..a68858dbe 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -79,7 +79,7 @@ ecl_apply_from_stack_frame(cl_env_ptr env, cl_object frame, cl_object x) env->function = fun; return APPLY(narg, fun->cfun.entry, sp); case t_cclosure: - env->function = fun->cclosure.env; + env->function = fun; return APPLY(narg, fun->cclosure.entry, sp); #ifdef CLOS case t_instance: @@ -124,7 +124,7 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x) env->function = fun; return fun->cfun.entry; case t_cclosure: - env->function = fun->cclosure.env; + env->function = fun; return fun->cclosure.entry; #ifdef CLOS case t_instance: diff --git a/src/c/hash.d b/src/c/hash.d index 5b55de9f4..3491441ab 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -611,7 +611,7 @@ static cl_object si_hash_table_iterate(cl_narg narg) { const cl_env_ptr the_env = ecl_process_env(); - cl_object env = the_env->function; + cl_object env = the_env->function->cclosure.env; cl_object index = CAR(env); cl_object ht = CADR(env); cl_fixnum i; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 6760eb176..0c2beed1e 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -757,7 +757,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.bottom); break; case t_cclosure: - the_env->function = reg0->cclosure.env; + the_env->function = reg0; reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.bottom); break; #ifdef CLOS diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 912393b9b..5e9dd832f 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -53,6 +53,8 @@ ;; (FUNCALL macro-expression ...) ((let ((name (first fun))) (setq fd (and (symbolp name) + ;; We do not want to macroexpad 'THE + (not (eq name 'THE)) (cmp-macro-function name)))) (c1funcall (list* (cmp-expand-macro fd fun) arguments))) ;; (FUNCALL lisp-expression ...) @@ -270,7 +272,8 @@ (defun wt-call (fun args &optional fname env) (if env (progn - (wt "(cl_env_copy->function=" env ",") + (setf *aux-closure* t) + (wt "(aux_closure.env="env",cl_env_copy->function=(void*)&aux_closure,") (wt-call fun args) (wt ")")) (progn diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 70e09c510..1747104ba 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -335,6 +335,7 @@ progress. The default value is T.") (defvar *env* 0) ; number of variables in current form (defvar *max-env* 0) ; maximum *env* in whole function (defvar *env-lvl* 0) ; number of levels of environments +(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls (defvar *next-cmacro* 0) ; holds the last cmacro number used. (defvar *next-cfun* 0) ; holds the last cfun used. diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 9b0ca2e05..9e9831244 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -112,6 +112,7 @@ (wt-nl-h "#include ")) ;;; Initialization function. (let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0) + (*aux-closure* nil) (*reservation-cmacro* (next-cmacro)) (c-output-file *compiler-output1*) (*compiler-output1* (make-string-output-stream)) @@ -376,6 +377,8 @@ (when (plusp *max-env*) (unless (eq closure-type 'CLOSURE) (wt-h " cl_object " *volatile* "env0;")) + (when *aux-closure* + (wt-h " struct ecl_cclosure aux_closure;")) (wt-h " cl_object " *volatile*) (dotimes (i *max-env*) (wt-h "CLV" i) @@ -569,6 +572,7 @@ (*lex* 0) (*max-lex* 0) (*env* (fun-env fun)) ; continue growing env (*max-env* *env*) (*env-lvl* 0) + (*aux-closure* nil) (*level* level) (*exit* 'RETURN) (*unwind-exit* '(RETURN)) (*destination* 'RETURN) @@ -581,7 +585,7 @@ " STCK" *reservation-cmacro*) (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") (when (eq (fun-closure fun) 'CLOSURE) - (wt "cl_object " *volatile* "env0 = cl_env_copy->function;")) + (wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) (wt-nl *volatile* "cl_object value0;") (when (>= (fun-debug fun) 2) (wt-nl "struct ihs_frame ihs;"))