diff --git a/src/c/compiler.d b/src/c/compiler.d
index 24bd2cb5c..b5a681980 100644
--- a/src/c/compiler.d
+++ b/src/c/compiler.d
@@ -31,9 +31,6 @@
 
 /********************* EXPORTS *********************/
 
-#define REGISTER_SPECIALS       1
-#define IGNORE_DECLARATIONS     0
-
 /* Flags for the compilation routines: */
 /* + Push the output of this form */
 #define FLAG_PUSH               1
@@ -51,8 +48,6 @@
 #define FLAG_LOAD               32
 #define FLAG_COMPILE            64
 
-#define ENV_RECORD_LOCATION(r)  CADDDR(r)
-
 #define ECL_SPECIAL_VAR_REF     -2
 #define ECL_UNDEFINED_VAR_REF   -1
 
@@ -350,9 +345,7 @@ static int
 c_register_constant(cl_env_ptr env, cl_object c)
 {
   int n = c_search_constant(env, c);
-  return (n < 0)?
-    asm_constant(env, c) :
-    n;
+  return (n < 0) ? asm_constant(env, c) : n;
 }
 
 static void
diff --git a/src/c/interpreter.d b/src/c/interpreter.d
index 06b17e301..04a318d13 100644
--- a/src/c/interpreter.d
+++ b/src/c/interpreter.d
@@ -188,7 +188,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
        VAR is the name of the variable for readability purposes.
     */
     CASE(OP_VAR); {
-      int lex_env_index;
+      cl_fixnum lex_env_index;
       GET_OPARG(lex_env_index, vector);
       reg0 = ecl_lex_env_get_var(lex_env, lex_env_index);
       THREAD_NEXT;
@@ -258,7 +258,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
     }
 
     /* OP_PUSH
-       Pushes the object in VALUES(0).
+       Pushes the object in REG0.
     */
     CASE(OP_PUSH); {
       ECL_STACK_PUSH(the_env, reg0);
@@ -439,8 +439,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
       THREAD_NEXT;
     }
     /* OP_POPREQ
-       Checks the arguments list. If there are remaining arguments,
-       REG0 = T and the value is on the stack, otherwise REG0 = NIL.
+       Checks the arguments list.
+       If there are remaining arguments, REG0 = ARG, otherwise signal an error.
     */
     CASE(OP_POPREQ); {
       if (ecl_unlikely(frame_index >= frame->frame.size)) {
@@ -450,8 +450,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
       THREAD_NEXT;
     }
     /* OP_POPOPT
-       Checks the arguments list. If there are remaining arguments,
-       REG0 = T and the value is on the stack, otherwise REG0 = NIL.
+       Checks the arguments list.
+       If there are remaining arguments, REG0 = T and the value is on the stack,
+       otherwise REG0 = NIL.
     */
     CASE(OP_POPOPT); {
       if (frame_index >= frame->frame.size) {
@@ -463,7 +464,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
       THREAD_NEXT;
     }
     /* OP_NOMORE
-       No more arguments.
+       Asserts that there are no more arguments in the frame.
     */
     CASE(OP_NOMORE); {
       if (ecl_unlikely(frame_index < frame->frame.size))
diff --git a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp
index ff12e25f6..043755393 100644
--- a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp
+++ b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp
@@ -528,33 +528,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
 ")
 
 
-;;; Code generation
-
-(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
-  (with-cxx-env ()
-    ;; After this step we still can add new objects, but objects that are
-    ;; already stored in VV or VVtemp must not change the location.
-    (optimize-cxx-data *referenced-objects*)
-    (setq *compiler-phase* 't2)
-    (with-open-file (*compiler-output1* c-pathname :direction :output
-                                                   :if-does-not-exist :create
-                                                   :if-exists :supersede)
-      (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
-      #-ecl-min
-      (multiple-value-bind (second minute hour day month year)
-          (get-decoded-time)
-        (declare (ignore second))
-        (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
-        (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
-      (wt-comment-nl "Source: ~A" source)
-      (with-open-file (*compiler-output2* h-pathname :direction :output
-                                                     :if-does-not-exist :create
-                                                     :if-exists :supersede)
-        (wt-nl1 "#include " *cmpinclude*)
-        (ctop-write init-name h-pathname data-pathname)
-        (terpri *compiler-output1*)
-        (terpri *compiler-output2*)))
-    (data-c-dump data-pathname)))
+;;; Code assembly
 
 (defun compiler-pass/assemble-cxx (input-file output-file
                                    &key
diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp
index 8cbb0c6ad..2ddb4285a 100644
--- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp
+++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp
@@ -22,7 +22,7 @@
   return-type           ;;; Lisp type for the output
   exact-return-type     ;;; Only use this expansion when the output is
                         ;;; declared to have a subtype of RETURN-TYPE
-  multiple-values       ;;; Works with all destinations, including VALUES / RETURN
+  multiple-values       ;;; Works with all destinations, including VALUEZ / LEAVE
   expansion             ;;; C template containing the expansion
   one-liner             ;;; Whether the expansion spans more than one line
 )
@@ -127,7 +127,7 @@
 
 (defun inline-type-matches (inline-info arg-types return-type)
   (when (and (not (inline-info-multiple-values inline-info))
-             (member *destination* '(VALUES RETURN)))
+             (member *destination* '(VALUEZ LEAVE)))
     (return-from inline-type-matches nil))
   (let* ((rts nil)
          (number-max nil))
@@ -215,7 +215,7 @@
           (cmpnote "Ignoring form ~S" c-expression))
       (wt-nl "value0 = ECL_NIL;")
       (wt-nl "cl_env_copy->nvalues = 0;")
-      (return-from produce-inline-loc 'RETURN))
+      (return-from produce-inline-loc 'LEAVE))
 
     ;; If the form is a one-liner, we can simply propagate this expression until the
     ;; place where the value is used.
@@ -225,12 +225,12 @@
                        ,(if (equalp output-rep-type '((VALUES &REST T)))
                             'VALUES NIL))))
 
-    ;; If the output is a in the VALUES vector, just write down the form and output
-    ;; the location of the data.
+    ;; If the output is a in the VALUES vector, just write down the form and
+    ;; output the location of the data.
     (when (equalp output-rep-type '((VALUES &REST T)))
       (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
                        'VALUES)
-      (return-from produce-inline-loc 'VALUES))
+      (return-from produce-inline-loc 'VALUEZ))
 
     ;; Otherwise we have to set up variables for holding the output.
     (flet ((make-output-var (type)
@@ -245,9 +245,9 @@
               (t
                (loop for v in output-vars
                      for i from 0
-                     do (let ((*destination* `(VALUE ,i))) (set-loc v)))
+                     do (set-loc `(VALUE ,i) v))
                (wt "cl_env_copy->nvalues = " (length output-vars) ";")
-               'VALUES))))))
+               'VALUEZ))))))
 
 (defun coerce-locs (inlined-args &optional types args-to-be-saved)
   ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the
diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp
index 7174e3613..846033d49 100644
--- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp
+++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp
@@ -42,17 +42,16 @@
 
 (defun save-inline-loc (loc)
   (let* ((rep-type (loc-representation-type (second loc)))
-         (temp (make-inline-temp-var (first loc) rep-type))
-         (*destination* temp))
-    (set-loc loc)
+         (temp (make-inline-temp-var (first loc) rep-type)))
+    (set-loc temp loc)
     temp))
 
 (defun emit-inlined-variable (form rest-forms)
   (let ((var (c1form-arg 0 form))
         (value-type (c1form-primary-type form)))
     (if (var-changed-in-form-list var rest-forms)
-        (let* ((temp (make-inline-temp-var value-type (var-rep-type var))))
-          (let ((*destination* temp)) (set-loc var))
+        (let ((temp (make-inline-temp-var value-type (var-rep-type var))))
+          (set-loc temp var)
           (list value-type temp))
         (list value-type var))))
 
@@ -72,9 +71,8 @@
          (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))
          (loc (call-global-loc fname fun args return-type expected-type))
          (type (type-and return-type (loc-type loc)))
-         (temp (make-inline-temp-var type (loc-representation-type loc)))
-         (*destination* temp))
-    (set-loc loc)
+         (temp (make-inline-temp-var type (loc-representation-type loc))))
+    (set-loc temp loc)
     (list type temp)))
 
 (defun emit-inlined-progn (form forms)
diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp
index b976064bd..f49e7c17d 100644
--- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp
+++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp
@@ -9,7 +9,7 @@
 (defvar *inline-blocks* 0)
 (defvar *opened-c-braces* 0)
 
-(defvar *emitted-local-funs* nil)
+(defvar *emitted-functions* nil)
 (defvar *inline-information* nil)
 
 ;;; Compiled code uses the following kinds of variables:
@@ -38,30 +38,27 @@
 
 ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
 ;;; If possible, *tail-recursion-info* holds
-;;;     ( c1-lambda-form  required-arg .... required-arg ),
+;;;     ( c1-lambda-form required-arg .... required-arg ),
 ;;; where each required-arg is a var-object.
 (defvar *tail-recursion-info* nil)
+(defvar *tail-recursion-mark* nil)
 
 ;;; --cmpexit.lsp--
 ;;;
-;;; *last-label* holds the label# of the last used label.
 ;;; *exit* holds an 'exit', which is
-;;      ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
-;;      RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT,
-;;      RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT).
+;;      LABEL instance or LEAVE.
 ;;; *unwind-exit* holds a list consisting of:
-;;      ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
-;;      JUMP, BDS-BIND (each pushed for a single special binding), or a
-;;      LCL (which holds the bind stack pointer used to unbind).
+;;      LABEL instance, LEAVE, FRAME, JUMP, BDS-BIND (each pushed for a single
+;;      special binding), or a LCL (which holds the bind stack pointer used to
+;;      unbind).
 ;;;
-(defvar *last-label* 0)
+
 (defvar *exit*)
 (defvar *unwind-exit*)
 
 ;;; C forms to find out (SETF fname) locations
 (defvar *setf-definitions*)             ; holds { name fun-vv name-vv  }*
 (defvar *global-cfuns-array*)           ; holds { fun-vv fname-loc fun }*
-(defvar *local-funs*)                   ; holds { fun }*
 
 ;;; T/NIL flag to determine whether one may generate lisp constant values as C
 ;;; structs.
@@ -94,17 +91,18 @@
          (*max-temp* 0)
          (*next-cfun* 0)
          (*last-label* 0)
+         (*unwind-exit* nil)
          (*inline-information*
            (ext:if-let ((r (machine-inline-information *machine*)))
              (si:copy-hash-table r)
              (make-inline-information *machine*)))
          (*setf-definitions* nil)
          (*global-cfuns-array* nil)
-         (*local-funs* nil)
          (*static-constants* nil)
          (*optimizable-constants* (make-optimizable-constants *machine*))
          (*permanent-objects* (make-array 128 :adjustable t :fill-pointer 0))
-         (*temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))
+         (*temporary-objects* (make-array 128 :adjustable t :fill-pointer 0))
+         (*compiler-declared-globals* (make-hash-table)))
      ,@body))
 
 (defun-cached env-var-name (n) eql
@@ -141,7 +139,7 @@
        (plusp *env*)
        (dolist (exit *unwind-exit*)
          (case exit
-           (RETURN (return NIL))
+           (LEAVE (return NIL))
            (BDS-BIND)
            (t (return T))))))
 
@@ -149,29 +147,64 @@
   (let ((code (incf *next-cfun*)))
     (format nil prefix code (lisp-to-c-name lisp-name))))
 
-(defun next-label ()
-  (cons (incf *last-label*) nil))
-
-(defun next-label* ()
-  (cons (incf *last-label*) t))
-
-(defun labelp (x)
-  (and (consp x) (integerp (si:cons-car x))))
-
-(defun maybe-next-label ()
-  (if (labelp *exit*)
-      *exit*
-      (next-label)))
-
-(defmacro with-exit-label ((label) &body body)
-  `(let* ((,label (next-label))
-          (*unwind-exit* (cons ,label *unwind-exit*)))
+(defmacro with-lexical-scope (() &body body)
+  `(progn
+     (wt-nl-open-brace)
      ,@body
-     (wt-label ,label)))
+     (wt-nl-close-brace)))
 
-(defmacro with-optional-exit-label ((label) &body body)
-  `(let* ((,label (maybe-next-label))
-          (*unwind-exit* (adjoin ,label *unwind-exit*)))
-     ,@body
-     (unless (eq ,label *exit*)
-       (wt-label ,label))))
+
+;;; *LAST-LABEL* holds the label# of the last used label. This is used by the
+;;; code generator to avoid duplicated labels in the same scope.
+
+(defvar *last-label* 0)
+
+;;; LABEL represents a destination for a possible control transfer. An unique ID
+;;; is assigned to ensure that there are no two labels of the same name. DENV
+;;; captures the dynamic environment of the label, so when we jump to the label
+;;; we may unwind the dynamic state (see the exit manager). USED-P is a flag is
+;;; set to T when the code "jumps" to the label. -- jd 2023-11-25
+(defstruct (label (:predicate labelp))
+  id
+  denv
+  used-p)
+
+(defun next-label (used-p)
+  (make-label :id (incf *last-label*) :denv *unwind-exit* :used-p used-p))
+
+;;; This macro binds VAR to a label where forms may exit or jump.
+;;; LABEL may be supplied to reuse a label when it exists.
+(defmacro with-exit-label ((var &optional exit) &body body)
+  (ext:with-gensyms (reuse label)
+    `(let* ((,label ,exit)
+            (,reuse (labelp ,label))
+            (,var (if ,reuse ,label (next-label nil)))
+            (*unwind-exit* (adjoin ,var *unwind-exit*)))
+       ,@body
+       (unless ,reuse
+         (wt-label ,var)))))
+
+;;; This macro estabilishes a frame to handle dynamic escapes like GO, THROW and
+;;; RETURN-FROM to intercept the control and eval UNWIND-PROTECT cleanup forms.
+;;; ecl_frs_pop is emited by the exit manager or the caller. -- jd 2023-11-19
+(defmacro with-unwind-frame ((tag) handler-form &body body)
+  `(with-lexical-scope ()
+     (let ((*unwind-exit* (list* 'FRAME *unwind-exit*)))
+       (wt-nl "ecl_frs_push(cl_env_copy," ,tag ");")
+       (wt-nl "if (__ecl_frs_push_result!=0) {")
+       ,handler-form
+       ,@(when body
+           `((wt-nl "} else {")
+             ,@body))
+       (wt-nl "}"))))
+
+(defmacro with-stack-frame ((var &optional loc) &body body)
+  (ext:with-gensyms (hlp)
+    `(with-lexical-scope ()
+       (let* ((,var ,(or loc "_ecl_inner_frame"))
+              (,hlp "_ecl_inner_frame_aux")
+              (*unwind-exit* (list* (list 'STACK ,var) *unwind-exit*)))
+         (wt-nl "struct ecl_stack_frame " ,hlp ";")
+         (wt-nl *volatile* "cl_object " ,var
+                "=ecl_stack_frame_open(cl_env_copy,(cl_object)&" ,hlp ",0);")
+         ,@body))))
diff --git a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp
index 85b01f027..6a5cc7fdd 100644
--- a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp
+++ b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp
@@ -110,13 +110,17 @@
 ;;; LABELS AND JUMPS
 ;;;
 
+(defun wt-nl-go (label)
+  (wt-nl-indent)
+  (wt-go label))
+
 (defun wt-go (label)
-  (setf (cdr label) t
-        label (car label))
-  (wt "goto L" label ";"))
+  (setf (label-used-p label) t)
+  (wt "goto L" (label-id label) ";"))
 
 (defun wt-label (label)
-  (when (cdr label) (wt-nl1 "L" (car label) ":;")))
+  (when (label-used-p label)
+    (wt-nl1 "L" (label-id label) ":;")))
 
 ;;;
 ;;; C/C++ COMMENTS
@@ -127,7 +131,7 @@
   (if single-line
       (progn
         (fresh-line stream)
-        (princ "/*      " stream))
+        (princ "/* " stream))
       (format stream "~50T/*  "))
   (let* ((l (1- (length text))))
     (declare (fixnum l))
@@ -144,8 +148,7 @@
           (t
            (princ c stream)))))
     (princ (schar text l) stream))
-  (format stream "~70T*/")
-  )
+  (format stream "~78T*/"))
 
 (defun do-wt-comment (message-or-format args single-line-p)
   (unless (and (symbolp message-or-format) (not (symbol-package message-or-format)))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
index e444642c1..dc0238668 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
@@ -82,17 +82,15 @@
 (defun tail-recursion-possible ()
   (dolist (ue *unwind-exit*
               (baboon :format-control "tail-recursion-possible: should never return."))
-    (cond ((eq ue 'TAIL-RECURSION-MARK)
+    (cond ((eq ue *tail-recursion-mark*)
            (return t))
-          ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME))
+          ((or (eq ue 'BDS-BIND) (eq ue 'FRAME))
            (return nil))
-          ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV)))
+          ((or (consp ue) (labelp ue) (eq ue 'IHS-ENV)))
           (t (baboon :format-control "tail-recursion-possible: unexpected situation.")))))
 
 (defun last-call-p ()
-  (member *exit*
-          '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT
-            RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT)))
+  (eq *exit* 'LEAVE))
 
 (defun c2try-tail-recursive-call (fun args)
   (when (and *tail-recursion-info*
@@ -101,16 +99,12 @@
              (tail-recursion-possible)
              (inline-possible (fun-name fun))
              (= (length args) (length (rest *tail-recursion-info*))))
-    (let* ((*destination* 'TRASH)
-           (*exit* (next-label))
-           (*unwind-exit* (cons *exit* *unwind-exit*)))
-      (c2psetq nil ;; We do not provide any C2FORM
-               (cdr *tail-recursion-info*) args)
-      (wt-label *exit*))
-    (unwind-no-exit 'TAIL-RECURSION-MARK)
-    (wt-nl "goto TTL;")
-    (cmpdebug "Tail-recursive call of ~s was replaced by iteration."
-              (fun-name fun))
+    (with-exit-label (*exit*)
+      (let ((*destination* 'TRASH))
+        ;; We do not provide any C2FORM.
+        (c2psetq nil (cdr *tail-recursion-info*) args)))
+    (unwind-jump *tail-recursion-mark*)
+    (cmpdebug "Tail-recursive call of ~s was replaced by iteration." (fun-name fun))
     t))
 
 (defun c2call-local (c1form fun args)
@@ -137,18 +131,14 @@
   (declare (ignore c1form))
   (let* ((*temp* *temp*)
          (loc (maybe-save-value form args)))
-    (wt-nl-open-brace)
-    (wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;")
-    (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
-    (let ((*unwind-exit* `((STACK "_ecl_inner_frame") ,@*unwind-exit*)))
-      (let ((*destination* (if values-p 'values 'return)))
+    (with-stack-frame (frame)
+      (let ((*destination* (if values-p 'VALUEZ 'LEAVE)))
         (dolist (arg args)
           (c2expr* arg)
           (if values-p
-              (wt-nl "ecl_stack_frame_push_values(_ecl_inner_frame);")
-              (wt-nl "ecl_stack_frame_push(_ecl_inner_frame,value0);"))))
-      (unwind-exit (call-stack-loc nil loc)))
-    (wt-nl-close-brace)))
+              (wt-nl "ecl_stack_frame_push_values(" frame ");")
+              (wt-nl "ecl_stack_frame_push(" frame ",value0);"))))
+      (unwind-exit (call-stack-loc nil loc)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp
index 2141be826..ecde25397 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp
@@ -23,33 +23,27 @@
       (let* ((blk-var (blk-var blk))
              (*env-lvl* *env-lvl*))
         (check-vref blk-var)
-        (wt-nl-open-brace)
-        (when (eq :object (var-kind blk-var))
-          (setf (var-loc blk-var) (next-lcl))
-          (wt-nl "cl_object " blk-var ";"))
-        (when (env-grows (var-ref-ccb blk-var))
-          ;; var is referenced from a closure which may escape.
-          (let ((env-lvl *env-lvl*))
-            (wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
-        (bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
-        (wt-nl-open-brace)
-        (wt-nl "ecl_frs_push(cl_env_copy," blk-var ");")
-        (wt-nl "if (__ecl_frs_push_result!=0) {")
-        (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
-          (unwind-exit 'VALUES)
-          (wt-nl "} else {")
-          (c2expr body)
-          (wt "}"))
-        (wt-nl-close-brace)
-        (when (var-ref-ccb blk-var) (decf *env*))
-        (wt-nl-close-brace))
+        (with-lexical-scope ()
+          (when (eq :object (var-kind blk-var))
+            (setf (var-loc blk-var) (next-lcl))
+            (wt-nl "cl_object " blk-var ";"))
+          (when (env-grows (var-ref-ccb blk-var))
+            ;; var is referenced from a closure which may escape.
+            (let ((env-lvl *env-lvl*))
+              (wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
+          (bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
+          (with-unwind-frame (blk-var)
+                             (unwind-exit 'VALUEZ)
+            (c2expr body))
+          (when (var-ref-ccb blk-var)
+            (decf *env*))))
       (c2expr body)))
 
 (defun c2return-from (c1form blk nonlocal val)
   (declare (ignore c1form))
   (if nonlocal
       (progn
-        (let ((*destination* 'VALUES))
+        (let ((*destination* 'VALUEZ))
           (c2expr* val))
         (let ((name (get-object (blk-name blk))))
           (wt-nl "cl_return_from(" (blk-var blk) "," name ");")))
@@ -66,11 +60,9 @@
       (dolist (x body (c2tagbody-body body))
         ;; Allocate labels.
         (when (and (tag-p x) (plusp (tag-ref x)))
-          (setf (tag-label x) (next-label*))
-          (setf (tag-unwind-exit x) *unwind-exit*)))
+          (setf (tag-jump x) (next-label t))))
       ;; some tag used non locally or inside an unwind-protect
-      (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
-            (*env* *env*) (*env-lvl* *env-lvl*)
+      (let ((*env* *env*) (*env-lvl* *env-lvl*)
             (*lex* *lex*) (*lcl* *lcl*)
             (*inline-blocks* 0)
             (env-grows (env-grows (var-ref-ccb tag-loc))))
@@ -84,54 +76,37 @@
           (maybe-open-inline-block)
           (wt-nl "cl_object " tag-loc ";"))
         (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
-        (wt-nl-open-brace)
-        (wt-nl "ecl_frs_push(cl_env_copy," tag-loc ");")
-        (wt-nl "if (__ecl_frs_push_result) {")
-        ;; Allocate labels.
-        (dolist (tag body)
-          (when (and (tag-p tag) (plusp (tag-ref tag)))
-            (setf (tag-label tag) (next-label))
-            (setf (tag-unwind-exit tag) *unwind-exit*)
-            (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))")
-            (wt-go (tag-label tag))))
-        (when (var-ref-ccb tag-loc)
-          (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))
-        (wt-nl "}")
-        (wt-nl-close-brace)
-        (c2tagbody-body body)
+        (with-unwind-frame (tag-loc)
+          (progn
+            ;; Allocate labels.
+            (dolist (tag body)
+              (when (and (tag-p tag) (plusp (tag-ref tag)))
+                (setf (tag-jump tag) (next-label nil))
+                (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))")
+                (wt-go (tag-jump tag))))
+            (when (var-ref-ccb tag-loc)
+              (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")))
+          (c2tagbody-body body))
         (close-inline-blocks))))
 
 (defun c2tagbody-body (body)
   ;;; INV: BODY is a list of tags and forms. We have processed the body
   ;;; so that the last element is always a form producing NIL.
-  (do ((l body (cdr l)))
-      ((null l))
-    (let* ((this-form (first l)))
-      (cond ((tag-p this-form)
-             (wt-label (tag-label this-form)))
-            ((endp (rest l))
-             ;; Last form, it is never a label!
-             (c2expr this-form))
-            (t
-             (let* ((next-form (second l))
-                    (*exit* (if (tag-p next-form)
-                                (tag-label next-form)
-                                (next-label)))
-                    (*unwind-exit* (cons *exit* *unwind-exit*))
-                    (*destination* 'TRASH))
-               (c2expr this-form)
-               (unless (tag-p next-form)
-                 (wt-label *exit*))))))))
+  (loop for (this-form next-form . rest) on body do
+    (cond ((tag-p this-form)
+           (wt-label (tag-jump this-form)))
+          ((tag-p next-form)
+           (with-exit-label (*exit* (tag-jump next-form))
+             (let ((*destination* 'TRASH))
+               (c2expr this-form))))
+          (t
+           (c2expr this-form)))))
 
 (defun c2go (c1form tag nonlocal)
   (declare (ignore c1form))
   (if nonlocal
-      (let ((var (tag-var tag)))
-        (wt-nl "cl_go(" var ",ecl_make_fixnum(" (tag-index tag) "));"))
-      ;; local go
-      (progn
-        (unwind-no-exit-until (tag-unwind-exit tag))
-        (wt-nl) (wt-go (tag-label tag)))))
+      (wt-nl "cl_go(" (tag-var tag) ",ecl_make_fixnum(" (tag-index tag) "));")
+      (unwind-jump (tag-jump tag))))
 
 
 (defun c2throw (c1form tag val &aux loc)
@@ -139,73 +114,53 @@
   (case (c1form-name tag)
     ((VARIABLE LOCATION) (setq loc (c1form-arg 0 tag)))
     (t (setq loc (make-temp-var))
-     (let ((*destination* loc)) (c2expr* tag))))
-  (let ((*destination* 'VALUES)) (c2expr* val))
+     (let ((*destination* loc))
+       (c2expr* tag))))
+  (let ((*destination* 'VALUEZ))
+    (c2expr* val))
   (wt-nl "cl_throw(" loc ");"))
 
 (defun c2catch (c1form tag body)
   (declare (ignore c1form))
   (let* ((new-destination (tmp-destination *destination*))
-         (code (incf *last-label*)))
+         (code (gensym "CATCH")))
     (let ((*destination* 'VALUE0))
       (c2expr* tag))
-    (let* ((*destination* new-destination)
-           (*unwind-exit* (cons 'FRAME *unwind-exit*)))
-      (wt-nl-open-brace)
-      (if (member new-destination '(TRASH VALUES))
-          (progn
-            (wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
-            (wt-nl "if (__ecl_frs_push_result==0) {")
-            (wt-comment "BEGIN CATCH ~A" code)
-            (with-indentation
-              (c2expr* body)))
-          (progn
-            (wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
-            (wt-nl "if (__ecl_frs_push_result) {")
-            (wt-comment "BEGIN CATCH ~A" code)
-            (with-indentation
-              (with-exit-label (label)
-                (let ((*exit* label))
-                  (unwind-exit 'VALUES))))
-            (wt-nl "} else {")
-            (with-indentation
-              (c2expr* body)))))
-    (wt-nl "}")
-    (wt-nl "ecl_frs_pop(cl_env_copy);")
-    (wt-comment "END CATCH ~A" code)
-    (wt-nl-close-brace)
+    (let ((*destination* new-destination))
+      (wt-comment "BEGIN CATCH ~A" code)
+      (with-unwind-frame ('VALUE0)
+        (unless (member new-destination '(TRASH VALUEZ))
+          (with-indentation
+            (with-exit-label (*exit*)
+              (unwind-exit 'VALUEZ))))
+        (with-indentation
+          (c2expr* body)))
+      (wt-nl "ecl_frs_pop(cl_env_copy);")
+      (wt-comment "END CATCH ~A" code))
     (unwind-exit new-destination)))
 
 (defun c2unwind-protect (c1form form body)
   (declare (ignore c1form))
-  (let* ((sp (make-lcl-var :rep-type :cl-index))
-         (nargs (make-lcl-var :rep-type :cl-index))
-         (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
-    (wt-nl-open-brace)
+  (with-stack-frame (frame)
+    ;; Here we compile the form which is protected. When this form is aborted,
+    ;; it continues with unwinding=TRUE. We call ecl_frs_pop() manually because
+    ;; we use C2EXPR* in the body.
     (wt-nl "volatile bool unwinding = FALSE;")
-    (wt-nl "cl_index " sp "=ECL_STACK_INDEX(cl_env_copy)," nargs ";")
     (wt-nl "ecl_frame_ptr next_fr;")
-    ;; Here we compile the form which is protected. When this form
-    ;; is aborted, it continues at the ecl_frs_pop() with unwinding=TRUE.
-    (wt-nl "ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG);")
-    (wt-nl "if (__ecl_frs_push_result) {")
-    (wt-nl "  unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
-    (wt-nl "} else {")
-    (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
-          (*destination* 'VALUES))
-      (c2expr* form))
-    (wt-nl "}")
+    (with-unwind-frame ("ECL_PROTECT_TAG")
+      (wt-nl "  unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
+      (let ((*destination* 'VALUEZ))
+        (c2expr* form)))
     (wt-nl "ecl_frs_pop(cl_env_copy);")
     ;; Here we save the values of the form which might have been
     ;; aborted, and execute some cleanup code. This code may also
     ;; be aborted by some control structure, but is not protected.
-    (wt-nl nargs "=ecl_stack_push_values(cl_env_copy);")
+    (wt-nl "ecl_stack_frame_push_values(" frame ");")
     (let ((*destination* 'TRASH))
       (c2expr* body))
-    (wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");")
+    (wt-nl "ecl_stack_frame_pop_values(" frame ");")
     ;; Finally, if the protected form was aborted, jump to the
     ;; next catch point...
     (wt-nl "if (unwinding) ecl_unwind(cl_env_copy,next_fr);")
     ;; ... or simply return the values of the protected form.
-    (unwind-exit 'VALUES)
-    (wt-nl-close-brace)))
+    (unwind-exit 'VALUEZ)))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
index b46cd206f..8bae8f54c 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
@@ -2,14 +2,9 @@
 ;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
 ;;;;  Copyright (c) 1990, Giuseppe Attardi
 ;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
-;;;;  Copyright (c) 2021, Daniel Kochmański
+;;;;  Copyright (c) 2023, Daniel Kochmański
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
 
 (in-package #:compiler)
@@ -26,30 +21,26 @@
   ;; other expressions will follow this one. We must thus create
   ;; a possible label so that the compiled forms exit right at
   ;; the point where the next form will be compiled.
-  (with-exit-label (label)
-    (let* ((*exit* label)
-           (*unwind-exit* (cons *exit* *unwind-exit*))
-           ;;(*lex* *lex*)
-           (*lcl* *lcl*)
-           (*temp* *temp*))
+  (with-exit-label (*exit*)
+    (let (;;(*lex* *lex*)
+          (*lcl* *lcl*)
+          (*temp* *temp*))
       (c2expr form))))
 
 (defun c2progn (c1form forms)
   (declare (ignore c1form))
-  ;; c1progn ensures that the length of forms is not less than 1.
-  (do ((l forms (cdr l))
-       (lex *lex*))
-      ((endp (cdr l))
-       (c2expr (car l)))
-    (let* ((this-form (first l))
-           (name (c1form-name this-form)))
-      (let ((*destination* 'TRASH))
-        (c2expr* (car l)))
-      (setq *lex* lex)  ; recycle lex locations
-      ;; Since PROGN does not have tags, any transfer of control means
-      ;; leaving the current PROGN statement.
-      (when (or (eq name 'GO) (eq name 'RETURN-FROM))
-        (return)))))
+  ;; INV C1PROGN ensures that the length of forms is not less than 1.
+  (loop with lex = *lex*
+        for (form next . rest) on forms do
+          (if (null next)
+              (c2expr form)
+              (let ((*destination* 'TRASH))
+                (c2expr* form)
+                ;; recycle lex locations
+                (setq *lex* lex)))
+        ;; Since PROGN does not have tags, any transfer of control means leaving
+        ;; the current PROGN statement.
+        until (member (c1form-name form) '(CL:GO CL:RETURN-FROM))))
 
 (defun c2if (c1form fmla form1 form2)
   (declare (ignore c1form))
@@ -58,7 +49,7 @@
               (eq (c1form-name form2) 'LOCATION))
          ;; Optimize (IF condition true-branch) or a situation in which
          ;; the false branch can be discarded.
-         (with-optional-exit-label (false-label)
+         (with-exit-label (false-label *exit*)
            (let ((*destination* `(JUMP-FALSE ,false-label)))
              (c2expr* fmla))
            (c2expr form1)))
@@ -66,7 +57,7 @@
               (eq (c1form-name form1) 'LOCATION))
          ;; Optimize (IF condition useless-value false-branch) when
          ;; the true branch can be discarded.
-         (with-optional-exit-label (true-label)
+         (with-exit-label (true-label *exit*)
            (let ((*destination* `(JUMP-TRUE ,true-label)))
              (c2expr* fmla))
            (c2expr form2)))
@@ -77,6 +68,14 @@
            (c2expr form1))
          (c2expr form2))))
 
+(defun jump-true-destination-p (dest)
+  (declare (si::c-local))
+  (and (consp dest) (eq (si:cons-car dest) 'JUMP-TRUE)))
+
+(defun jump-false-destination-p (dest)
+  (declare (si::c-local))
+  (and (consp dest) (eq (si:cons-car dest) 'JUMP-FALSE)))
+
 (defun negate-argument (inlined-arg dest-loc)
   (declare (si::c-local))
   (let* ((loc (second inlined-arg))
@@ -105,19 +104,9 @@
           (t
            (let ((*inline-blocks* 0)
                  (*temp* *temp*))
-             (unwind-exit (negate-argument
-                           (emit-inline-form arg nil)
-                           dest))
+             (unwind-exit (negate-argument (emit-inline-form arg nil) dest))
              (close-inline-blocks))))))
 
-(defun jump-true-destination-p (dest)
-  (declare (si::c-local))
-  (and (consp dest) (eq (si:cons-car dest) 'JUMP-TRUE)))
-
-(defun jump-false-destination-p (dest)
-  (declare (si::c-local))
-  (and (consp dest) (eq (si:cons-car dest) 'JUMP-FALSE)))
-
 (defun c2fmla-and (c1form butlast last)
   (declare (ignore c1form))
   (if (jump-false-destination-p *destination*)
@@ -148,77 +137,24 @@
              (dolist (f butlast)
                (let ((*destination* 'VALUE0))
                  (c2expr* f))
-               (set-jump-true 'VALUE0 normal-exit))
+               (wt-nl "if (" 'VALUE0 "!=ECL_NIL) ")
+               (wt-open-brace) (unwind-jump normal-exit) (wt-nl-close-brace))
              (c2expr last))
            (unwind-exit 'VALUE0)))))
 
-(defun set-jump-true (loc label)
-  (multiple-value-bind (constantp value)
-      (loc-immediate-value-p loc)
-    (cond ((not constantp)
-           (cond ((eq (loc-representation-type loc) :bool)
-                  (wt-nl "if (" loc ") {"))
-                 (t
-                  (wt-nl "if ((")
-                  (wt-coerce-loc :object loc)
-                  (wt ")!=ECL_NIL) {")))
-           (cond ((unwind-no-exit label)
-                  (incf *opened-c-braces*)
-                  (wt-nl) (wt-go label)
-                  (wt-nl-close-brace))
-                 (t
-                  (wt " ") (wt-go label) (wt " }"))))
-          ((null value))
-          (t
-           (unwind-no-exit label)
-           (wt-nl) (wt-go label)))))
-
-(defun set-jump-false (loc label)
-  (multiple-value-bind (constantp value)
-      (loc-immediate-value-p loc)
-    (cond ((not constantp)
-           (cond ((eq (loc-representation-type loc) :bool)
-                  (wt-nl "if (!(" loc ")) {"))
-                 (t
-                  (wt-nl "if (Null(")
-                  (wt-coerce-loc :object loc)
-                  (wt ")) {")))
-           (cond ((unwind-no-exit label)
-                  (incf *opened-c-braces*)
-                  (wt-nl) (wt-go label)
-                  (wt-nl-close-brace))
-                 (t
-                  (wt " ") (wt-go label) (wt " }"))))
-          (value)
-          (t
-           (unwind-no-exit label)
-           (wt-nl) (wt-go label)))))
-
 (defun c2mv-prog1 (c1form form body)
-  (wt-nl-open-brace)
-  (wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;")
-  (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
-  (let ((*unwind-exit* `((STACK "_ecl_inner_frame") ,@*unwind-exit*)))
-    (let ((*destination* 'VALUES))
+  (declare (ignore c1form))
+  (with-stack-frame (frame)
+    (let ((*destination* 'VALUEZ))
       (c2expr* form))
-    (wt-nl "ecl_stack_frame_push_values(_ecl_inner_frame);")
+    (wt-nl "ecl_stack_frame_push_values(" frame ");")
     (let ((*destination* 'TRASH))
       (mapc #'c2expr* body))
-    (wt-nl "ecl_stack_frame_pop_values(_ecl_inner_frame);"))
-  (wt-nl "ecl_stack_frame_close(_ecl_inner_frame);")
-  (wt-nl-close-brace)
-  (unwind-exit 'values))
+    (wt-nl "ecl_stack_frame_pop_values(" frame ");")
+    (unwind-exit 'VALUEZ)))
 
 (defun c2values (c1form forms)
   (declare (ignore c1form))
-  (when (and (eq *destination* 'RETURN-OBJECT)
-             (rest forms)
-             (consp *current-form*)
-             (eq 'cl:DEFUN (first *current-form*)))
-    (cmpwarn "Trying to return multiple values. ~
-              ~%;But ~a was proclaimed to have single value.~
-              ~%;Only first one will be assured."
-             (second *current-form*)))
   (cond
    ;; When the values are not going to be used, then just
    ;; process each form separately.
@@ -227,25 +163,25 @@
     ;; We really pass no value, but we need UNWIND-EXIT to trigger all the
     ;; frame-pop and all other exit forms.
     (unwind-exit 'VALUE0))
-   ;; For (VALUES) we can replace the output with either NIL (if the value
-   ;; is actually used) and set only NVALUES when the value is the output
-   ;; of a function.
+   ;; For (VALUES) we can replace the output with either NIL (if the value is
+   ;; actually used) and set only NVALUES when the value is the output of a
+   ;; function.
    ((endp forms)
-    (cond ((eq *destination* 'RETURN)
+    (cond ((eq *destination* 'LEAVE)
            (wt-nl "value0 = ECL_NIL;")
            (wt-nl "cl_env_copy->nvalues = 0;")
-           (unwind-exit 'RETURN))
-          ((eq *destination* 'VALUES)
+           (unwind-exit 'LEAVE))
+          ((eq *destination* 'VALUEZ)
            (wt-nl "cl_env_copy->values[0] = ECL_NIL;")
            (wt-nl "cl_env_copy->nvalues = 0;")
-           (unwind-exit 'VALUES))
+           (unwind-exit 'VALUEZ))
           (t
            (unwind-exit *vv-nil*))))
    ;; For a single form, we must simply ensure that we only take a single
    ;; value of those that the function may output.
    ((endp (rest forms))
     (let ((form (first forms)))
-      (if (or (not (member *destination* '(RETURN VALUES)))
+      (if (or (not (member *destination* '(LEAVE VALUEZ)))
               (c1form-single-valued-p form))
           (c2expr form)
           (progn
@@ -266,5 +202,5 @@
           ((null vl))
         (declare (fixnum i))
         (wt-nl "cl_env_copy->values[" i "] = " (first vl) ";"))
-      (unwind-exit 'VALUES)
+      (unwind-exit 'VALUEZ)
       (close-inline-blocks)))))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
index 8ef8d7d18..041785fad 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
@@ -4,203 +4,198 @@
 ;;;;
 ;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 ;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 2023, Daniel Kochmański.
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
-;;;;    See file '../Copyright' for full details.
 
 ;;;; CMPEXIT  Exit manager.
+;;;;
+;;;; The exit manager has two main operators that unwind the dynamic context:
+;;;;
+;;;;     (UNWIND-EXIT value) carries VALUE to *DESTINATION* and unwinds to *EXIT*.
+;;;;     (UNWIND-JUMP label) unwinds to LABEL.
+;;;;
 
 (in-package "COMPILER")
 
+(defun unwind-exit (loc)
+  (flet ((unwind-cond-p ()
+           (and (consp *destination*)
+                (member (si:cons-car *destination*) '(JUMP-FALSE JUMP-TRUE))))
+         (unwind-jump-p ()
+           (labelp *exit*))
+         (unwind-exit-p ()
+           (eq *exit* 'LEAVE)))
+    (cond ((unwind-cond-p) (unwind-cjump loc))
+          ((unwind-jump-p) (unwind-label loc))
+          ((unwind-exit-p) (unwind-leave loc))
+          (t (baboon-exit-invalid *exit*)))))
+
+(defun unwind-jump (exit)
+  (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
+      (compute-unwind (label-denv exit))
+    (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+    (wt-nl-go exit)))
+
+;;;
+
+(defun baboon-exit-not-found (exit)
+  (baboon :format-control "The value of exit~%~A~%is not found in *UNWIND-EXIT*~%~A"
+          :format-arguments (list exit *unwind-exit*)))
+
+(defun baboon-exit-invalid (exit)
+  (baboon :format-control "The value of exit~%~A~%is not valid."
+          :format-arguments (list exit)))
+
+(defun baboon-unwind-invalid (unwind-exit)
+  (baboon :format-control "The value~%~A~%is not a tail of *UNWIND-EXIT*~%~A"
+          :format-arguments (list unwind-exit *unwind-exit*)))
+
+(defun baboon-unwind-exit (exit)
+  (baboon :format-control "The value of exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid."
+          :format-arguments (list exit *unwind-exit*)))
+
+(defun destination-value-matters-p (dest)
+  (declare (si::c-local))
+  (if (atom dest)
+      (not (eq dest 'TRASH))
+      (not (member (car dest) '(JUMP-FALSE JUMP-TRUE)))))
+
 ;;; UNWIND-EXIT TAGS       PURPOSE
 ;;;
-;;; number              -> unknown purpose
-;;; JUMP                -> unknown purpose
 ;;; FRAME               -> ecl_frs_push()
+;;; (STACK frame)       -> ecl_stack_frame_open(env, frame, initial_size)
 ;;; IHS                 -> ihs push
 ;;; IHS-ENV             -> ihs push
 ;;; BDS-BIND            -> binding of 1 special variable
-;;; (number . {T|NIL})  -> label
-;;; (LCL n)             -> n local variables
-;;; (STACK n)           -> n elements pushed in stack
-;;; TAIL-RECURSION-MARK -> TTL: label created
-;;; RETURN*             -> outermost location
-;;;
-;;; (*) also RETURN-FIXNUM, -CHARACTER, -SINGLE-FLOAT
-;;;     -DOUBLE-FLOAT, -OBJECT.
-;;;
-(defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p)
-  (declare (fixnum bds-bind))
-  (let ((some nil))
-    (when stack-frame
-      (setf some t)
-      (if (stringp stack-frame)
-          (wt-nl "ecl_stack_frame_close(" stack-frame ");")
-          (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");")))
-    (when bds-lcl
-      (setf some t)
-      (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
-    (cond ((< bds-bind 4)
-           (dotimes (n bds-bind)
-             (declare (fixnum n))
-             (setf some t)
-             (wt-nl "ecl_bds_unwind1(cl_env_copy);")))
-          (t
-           (setf some t)
-           (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");")))
-    (case ihs-p
-      (IHS
-       (setf some t)
-       (wt-nl "ecl_ihs_pop(cl_env_copy);"))
-      (IHS-ENV
-       (setf some t)
-       (wt-nl "ihs.lex_env = _ecl_debug_env;")))
-    some))
+;;; (LCL n)             -> binding stack pointer to Nth local variable
+;;; LEAVE               -> outermost location
+;;; #<label id used-p>  -> label (basic block leader)
 
-(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
-  (declare (fixnum bds-bind))
-  (when (consp *destination*)
-    (case (car *destination*)
-      (JUMP-TRUE
-       (set-jump-true loc (second *destination*))
-       (when (eq loc *vv-t*)
-         (return-from unwind-exit)))
-      (JUMP-FALSE
-       (set-jump-false loc (second *destination*))
-       (when (eq loc *vv-nil*)
-         (return-from unwind-exit)))))
-  (dolist (ue *unwind-exit* (baboon-improper-*exit*))
-    ;; perform all unwind-exit's which precede *exit*
-    (cond
-      ((consp ue)                   ; ( label# . ref-flag )| (STACK n) |(LCL n)
-       (cond ((eq (car ue) 'STACK)
-              (setf stack-frame (second ue)))
-             ((eq (car ue) 'LCL)
-              (setq bds-lcl ue bds-bind 0))
-             ((eq ue *exit*)
-              ;; all body forms except the last (returning) are dealt here
-              (cond ((and (consp *destination*)
-                          (or (eq (car *destination*) 'JUMP-TRUE)
-                              (eq (car *destination*) 'JUMP-FALSE)))
-                     (unwind-bds bds-lcl bds-bind stack-frame ihs-p))
-                    ((not (or bds-lcl (plusp bds-bind) stack-frame))
-                     (set-loc loc))
-                    ;; Save the value if LOC may possibly refer
-                    ;; to special binding.
-                    ((or (loc-refers-to-special-p loc)
-                         (loc-refers-to-special-p *destination*))
-                     (let* ((*temp* *temp*)
-                            (temp (make-temp-var)))
-                       (let ((*destination* temp))
-                         (set-loc loc)) ; temp <- loc
-                       (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
-                       (set-loc temp))) ; *destination* <- temp
-                    (t
-                     (set-loc loc)
-                     (unwind-bds bds-lcl bds-bind stack-frame ihs-p)))
-              (when jump-p (wt-nl) (wt-go *exit*))
-              (return))
-             (t (setq jump-p t))))
-      ((numberp ue)
-       (baboon-unwind-exit ue)
-       (setq bds-lcl ue bds-bind 0))
-      (t (case ue
-           (IHS (setf ihs-p ue))
-           (IHS-ENV (setf ihs-p (or ihs-p ue)))
-           (BDS-BIND (incf bds-bind))
-           (RETURN
-             (unless (eq *exit* 'RETURN) (baboon-unwind-exit ue))
-             ;; *destination* must be either RETURN or TRASH.
-             (cond ((eq loc 'VALUES)
-                    ;; from multiple-value-prog1 or values
-                    (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
-                    (wt-nl "return cl_env_copy->values[0];"))
-                   ((eq loc 'RETURN)
-                    ;; from multiple-value-prog1 or values
-                    (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
-                    (wt-nl "return value0;"))      
-                   (t
-                    (let* ((*destination* 'RETURN))
-                      (set-loc loc))
-                    (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
-                    (wt-nl "return value0;")))
-             (return))
-           ((RETURN-FIXNUM RETURN-CHARACTER RETURN-OBJECT
-             RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT RETURN-LONG-FLOAT
-             RETURN-CSFLOAT RETURN-CSFLOAT RETURN-CSFLOAT)
-            (when (eq *exit* ue)
-              ;; *destination* must be RETURN-FIXNUM
-              (setq loc (list 'COERCE-LOC
-                              (getf '(RETURN-FIXNUM :fixnum
-                                      RETURN-CHARACTER :char
-                                      RETURN-SINGLE-FLOAT :float
-                                      RETURN-DOUBLE-FLOAT :double
-                                      RETURN-CSFLOAT :csfloat
-                                      RETURN-CDFLOAT :cdfloat
-                                      RETURN-CLFLOAT :clfloat
-                                      RETURN-OBJECT :object)
-                                    ue)
-                              loc))
-              (if (or bds-lcl (plusp bds-bind))
-                  (let ((lcl (make-lcl-var :type (second loc))))
-                    (wt-nl-open-brace)
-                    (wt-nl "cl_fixnum " lcl "= " loc ";")
-                    (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
-                    (wt-nl "return(" lcl ");")
-                    (wt-nl-close-brace))
-                  (progn
-                    (wt-nl "return(" loc ");")))
-              (return)))
-           (FRAME
-            (let ((*destination* (tmp-destination *destination*)))
-              (set-loc loc)
-              (setq loc *destination*))
-            (wt-nl "ecl_frs_pop(cl_env_copy);"))
-           (TAIL-RECURSION-MARK)
-           (JUMP (setq jump-p t))
-           (t (baboon-unwind-exit ue))))))
-  ;;; Never reached
-  )
+(defun perform-unwind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
+  (declare (si::c-local)
+           (fixnum frs-bind bds-bind))
+  (when (plusp frs-bind)
+    (wt-nl "ecl_frs_pop_n(cl_env_copy, " frs-bind ");"))
+  (when stack-frame
+    (wt-nl "ecl_stack_frame_close(" stack-frame ");"))
+  (when bds-lcl
+    (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
+  (if (< bds-bind 4)
+      (dotimes (n bds-bind)
+        (declare (ignorable n))
+        (wt-nl "ecl_bds_unwind1(cl_env_copy);"))
+      (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
+  (case ihs-p
+    (IHS     (wt-nl "ecl_ihs_pop(cl_env_copy);"))
+    (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
 
-(defun baboon-improper-*exit* ()
-  (baboon :format-control "The value of *EXIT*~%~A~%is not found in *UNWIND-EXIT*~%~A"
-          :format-arguments (list *exit* *unwind-exit*)))
-
-(defun baboon-unwind-exit (ue)
-  (baboon :format-control "The value of unwind exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid."
-          :format-arguments (list ue *unwind-exit*)))
-
-(defun unwind-no-exit-until (last-cons)
+(defun compute-unwind (last-cons)
+  (declare (si::c-local))
   (loop with bds-lcl = nil
-     with bds-bind = 0
-     with stack-frame = nil
-     with ihs-p = nil
-     for unwind-exit on *unwind-exit*
-     for ue = (car unwind-exit)
-     until (eq unwind-exit last-cons)
-     do (cond
-          ((consp ue)
-           (when (eq (first ue) 'STACK)
-             (setf stack-frame (second ue))))
-          ((numberp ue)
-           (setq bds-lcl ue bds-bind 0))
-          ((eq ue 'BDS-BIND)
-           (incf bds-bind))
-          ((eq ue 'FRAME)
-           (wt-nl "ecl_frs_pop(cl_env_copy);"))
-          ((eq ue 'JUMP))
-          ((eq ue 'IHS-ENV)
-           (setf ihs-p ue))
-          (t (baboon-unwind-exit ue)))
-     finally (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p))))
+        with bds-bind = 0
+        with stack-frame = nil
+        with ihs-p = nil
+        with frs-bind = 0
+        with jump-p = nil
+        with exit-p = nil
+        for unwind-exit on *unwind-exit*
+        for ue = (car unwind-exit)
+        until (eq unwind-exit last-cons)
+        do (cond
+             ((consp ue)
+              (case (first ue)
+                (STACK (setq stack-frame (second ue)))
+                (LCL (setq bds-lcl ue bds-bind 0))
+                (otherwise (baboon-unwind-exit ue))))
+             ((labelp ue)
+              (setf jump-p t))
+             ((eq ue 'BDS-BIND)
+              (incf bds-bind))
+             ((eq ue 'FRAME)
+              (incf frs-bind))
+             ((eq ue 'IHS)
+              (setf ihs-p ue))
+             ((eq ue 'IHS-ENV)
+              (setf ihs-p (or ihs-p ue)))
+             ((eq ue 'LEAVE)
+              (setf exit-p t))
+             (t (baboon-unwind-exit ue)))
+        finally (return (values frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p))))
 
-(defun unwind-no-exit (exit)
-  (let ((where (member exit *unwind-exit* :test #'eq)))
-    (unless where
-      (baboon :format-control "Unwind-exit label ~A not found"
-              :format-arguments (list exit)))
-    (unwind-no-exit-until where)))
+(defun unwind-leave (loc)
+  (declare (si::c-local))
+  (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
+      (compute-unwind nil)
+    (declare (fixnum frs-bind bds-bind))
+    ;; *destination* must be either LEAVE or TRASH.
+    (cond ((eq loc 'VALUEZ)
+           ;; from multiple-value-prog1 or values
+           (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+           (wt-nl "return cl_env_copy->values[0];"))
+          ((eq loc 'LEAVE)
+           ;; from multiple-value-prog1 or values
+           (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+           (wt-nl "return value0;"))
+          (t
+           (set-loc 'LEAVE loc)
+           (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+           (wt-nl "return value0;")))))
+
+(defun unwind-label (loc)
+  (declare (si::c-local))
+  (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p)
+      (compute-unwind (or (member *exit* *unwind-exit* :test #'eq)
+                          (baboon-exit-not-found *exit*)))
+    (declare (fixnum frs-bind bds-bind))
+    ;; This operator does not cross the function boundary.
+    (assert (null exit-p))
+    (cond ((and (destination-value-matters-p *destination*)
+                (or (plusp frs-bind) bds-lcl (plusp bds-bind) stack-frame)
+                (or (loc-refers-to-special-p loc)
+                    (loc-refers-to-special-p *destination*)))
+           ;; Save the value if LOC may possibly refer to special binding.
+           (let* ((*temp* *temp*)
+                  (temp (make-temp-var)))
+             (set-loc temp loc)
+             (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+             (set-loc *destination* temp)))
+          (t
+           (set-loc *destination* loc)
+           (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
+    ;; When JUMP-P is NULL then we "fall through" onto the exit block.
+    (when jump-p
+      (wt-nl-go *exit*))))
+
+;;; Conditional JUMP based on the value of *DESTINATION*. This allows FMLA to
+;;; jump over *EXIT* to skip the dead part of the computation. -- jd 2023-11-16
+(defun unwind-cjump (loc)
+  (declare (si::c-local))
+  (multiple-value-bind (constantp value) (loc-immediate-value-p loc)
+    (destructuring-bind (target label) *destination*
+      (ecase target
+        (JUMP-TRUE
+         (cond ((not constantp)
+                (case (loc-representation-type loc)
+                  (:bool     (wt-nl "if (" loc ") "))
+                  (:object   (wt-nl "if (" loc "!=ECL_NIL) "))
+                  (otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) ")))
+                (wt-open-brace) (unwind-jump label) (wt-nl-close-brace))
+               ((not (null value))
+                (unwind-jump label)))
+         (unless (and constantp (not (null value)))
+           (let ((*destination* 'TRASH))
+             (unwind-exit *vv-nil*))))
+        (JUMP-FALSE
+         (cond ((not constantp)
+                (case (loc-representation-type loc)
+                  (:bool     (wt-nl "if (!(" loc ")) "))
+                  (:object   (wt-nl "if (Null(" loc ")) "))
+                  (otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) ")))
+                (wt-open-brace) (unwind-jump label) (wt-nl-close-brace))
+               ((null value)
+                (unwind-jump label)))
+         (unless (and constantp (null value))
+           (let ((*destination* 'TRASH))
+             (unwind-exit *vv-t*))))))))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp
index 01342c6b5..92915b386 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp
@@ -57,7 +57,7 @@
                   )
                  (t
                   (c2expr* form)))
-        finally (unwind-exit nil)))
+        finally (unwind-exit *vv-nil*)))
 
 (defun c2c-inline (c1form arguments &rest rest)
   (declare (ignore c1form))
@@ -72,6 +72,8 @@
   (when (eql return-type :void)
     (setf return-p nil))
   (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type)))
+        (vars (loop for n from 0 below (length arg-types)
+                    collect (format nil "var~d" n)))
         (fmod (case call-type
                 ((:cdecl :default) "")
                 (:stdcall "__stdcall ")
@@ -80,30 +82,28 @@
     (wt-nl-h "static " return-type-name " " fmod c-name "(")
     (wt-nl1  "static " return-type-name " " fmod c-name "(")
     (loop with comma = ""
-          for n from 0
+          for var in vars
           for type in arg-types
           for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type))
-          do (wt-h comma arg-type-name " var" n)
-             (wt   comma arg-type-name " var" n)
+          do (wt-h comma arg-type-name " " var)
+             (wt   comma arg-type-name " " var)
              (setf comma ","))
     (wt ")")
     (wt-h ");")
-    (wt-nl-open-brace)
-    (when return-p
-      (wt-nl return-type-name " output;"))
-    (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
-    (wt-nl "cl_object aux;")
-    (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
-    (loop for n from 0
-          and type in arg-types
-          and ct in arg-type-constants
-          do (wt-nl "ecl_stack_frame_push("
-                    "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")"
-                    ");"))
-    (wt-nl "aux = ecl_apply_from_stack_frame(frame,"
-           "ecl_fdefinition(" c-name-constant "));")
-    (wt-nl "ecl_stack_frame_close(frame);")
-    (when return-p
-      (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);")
-      (wt-nl "return output;"))
-    (wt-nl-close-brace)))
+    (with-lexical-scope ()
+      (when return-p
+        (wt-nl return-type-name " output;"))
+      (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
+      (wt-nl "cl_object aux;")
+      (with-stack-frame (frame)
+        (loop for var in vars
+              and type in arg-types
+              and ct in arg-type-constants
+              do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");"))
+        (wt-nl "aux = ecl_apply_from_stack_frame(" frame ","
+               "ecl_fdefinition(" c-name-constant "));")
+        ;; No UNWIND-EXIT, so we must close the frame manually.
+        (wt-nl "ecl_stack_frame_close(" frame ");"))
+      (when return-p
+        (set-loc `(ffi-data-ref "output" ,return-type-code) "aux")
+        (wt-nl "return output;")))))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
index f6615f7a7..8c084f5cd 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
@@ -16,47 +16,45 @@
 
 (defun c2locals (c1form funs body labels ;; labels is T when deriving from labels
                  &aux
-                 (*env* *env*)
-                 (*inline-blocks* 0)
-                 (*env-lvl* *env-lvl*))
+                   (*env* *env*)
+                   (*inline-blocks* 0)
+                   (*env-lvl* *env-lvl*))
   (declare (ignore c1form labels))
-  ;; create location for each function which is returned,
-  ;; either in lexical:
+  ;; create location for each function which is returned, either in lexical:
   (loop with env-grows = nil
-     with closed-vars = '()
-     for fun in funs
-     for var = (fun-var fun)
-     when (plusp (var-ref var))
-     do (case (var-kind var)
-          ((lexical closure)
-           (push var closed-vars)
-           (unless env-grows
-             (setq env-grows (var-ref-ccb var))))
-          (otherwise
-           (maybe-open-inline-block)
-           (bind (next-lcl) var)
-           (wt-nl "cl_object " *volatile* var ";")))
-     finally
-     ;; if we have closed variables
-       (when (env-grows env-grows)
-         (maybe-open-inline-block)
-         (let ((env-lvl *env-lvl*))
-           (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
-     ;; bind closed locations because of possible circularities
-       (loop for var in closed-vars
-          do (bind *vv-nil* var)))
+        with closed-vars = '()
+        for fun in funs
+        for var = (fun-var fun)
+        when (plusp (var-ref var))
+          do (case (var-kind var)
+               ((lexical closure)
+                (push var closed-vars)
+                (unless env-grows
+                  (setq env-grows (var-ref-ccb var))))
+               (otherwise
+                (maybe-open-inline-block)
+                (bind (next-lcl) var)
+                (wt-nl "cl_object " *volatile* var ";")))
+        finally
+           ;; if we have closed variables
+           (when (env-grows env-grows)
+             (maybe-open-inline-block)
+             (let ((env-lvl *env-lvl*))
+               (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
+           ;; bind closed locations because of possible circularities
+           (loop for var in closed-vars
+                 do (bind *vv-nil* var)))
   ;; create the functions:
-  (mapc #'new-local funs)
+  (map nil #'update-function-env funs)
   ;; - then assign to it
   (loop for fun in funs
-     for var = (fun-var fun)
-     when (plusp (var-ref var))
-     do (set-var (list 'MAKE-CCLOSURE fun) var))
+        for var = (fun-var fun)
+        when (plusp (var-ref var))
+          do (set-var (list 'MAKE-CCLOSURE fun) var))
   (c2expr body)
   (close-inline-blocks))
 
-;;; Mechanism for sharing code.
-(defun new-local (fun)
+(defun update-function-env (fun)
   (declare (type fun fun))
   (case (fun-closure fun)
     (CLOSURE
@@ -71,7 +69,7 @@
     (otherwise
      (setf (fun-level fun) 0
            (fun-env fun) 0)))
-  (push fun *local-funs*))
+  (register-function fun))
 
 #| Steps:
  1. defun creates declarations for requireds + va_alist
@@ -214,27 +212,26 @@
     ;; which is what we do here.
     (let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)))
       ;; counter for optionals
-      (wt-nl-open-brace)
-      (wt-nl "int i = " nreq ";")
-      (do ((opt optionals (cdddr opt))
-           (type-check optional-type-check-forms (cdr type-check)))
-          ((endp opt))
-        (wt-nl "if (i >= narg) {")
-        (let ((*opened-c-braces* (1+ *opened-c-braces*)))
-          (bind-init (second opt) (first opt))
-          (when (third opt)
-            (bind *vv-nil* (third opt))))
-        (wt-nl "} else {")
-        (let ((*opened-c-braces* (1+ *opened-c-braces*))
-              (*unwind-exit* *unwind-exit*))
-          (wt-nl "i++;")
-          (bind va-arg-loc (first opt))
-          (if (car type-check)
-              (c2expr* (car type-check)))
-          (when (third opt)
-            (bind *vv-t* (third opt))))
-        (wt-nl "}"))
-      (wt-nl-close-brace)))
+      (with-lexical-scope ()
+        (wt-nl "int i = " nreq ";")
+        (do ((opt optionals (cdddr opt))
+             (type-check optional-type-check-forms (cdr type-check)))
+            ((endp opt))
+          (wt-nl "if (i >= narg) {")
+          (let ((*opened-c-braces* (1+ *opened-c-braces*)))
+            (bind-init (second opt) (first opt))
+            (when (third opt)
+              (bind *vv-nil* (third opt))))
+          (wt-nl "} else {")
+          (let ((*opened-c-braces* (1+ *opened-c-braces*))
+                (*unwind-exit* *unwind-exit*))
+            (wt-nl "i++;")
+            (bind va-arg-loc (first opt))
+            (if (car type-check)
+                (c2expr* (car type-check)))
+            (when (third opt)
+              (bind *vv-t* (third opt))))
+          (wt-nl "}")))))
 
   (when (or rest key-flag allow-other-keys)
     (cond ((not (or key-flag allow-other-keys))
@@ -295,14 +292,12 @@
       (when flag
         (setf (second KEYVARS[i]) (+ nkey i))
         (bind KEYVARS[i] flag))))
-
   (when *tail-recursion-info*
-    (push 'TAIL-RECURSION-MARK *unwind-exit*)
-    (wt-nl1 "TTL:"))
-
+    (setf *tail-recursion-mark* (next-label t))
+    (push *tail-recursion-mark* *unwind-exit*)
+    (wt-label *tail-recursion-mark*))
   ;;; Now the parameters are ready, after all!
   (c2expr body)
-
   (close-inline-blocks))
 
 (defun wt-maybe-check-num-arguments (use-narg minarg maxarg fname)
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
index 9a45ff098..43b58576d 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
@@ -37,22 +37,6 @@
         (t
          (unknown-location 'wt-loc loc))))
 
-(defun wt-lcl (lcl)
-  (unless (numberp lcl)
-    (baboon :format-control "wt-lcl: ~s NaN"
-            :format-arguments (list lcl)))
-  (wt "v" lcl))
-
-(defun wt-lcl-loc (lcl &optional type name)
-  (declare (ignore type))
-  (unless (numberp lcl)
-    (baboon :format-control "wt-lcl-loc: ~s NaN"
-            :format-arguments (list lcl)))
-  (wt "v" lcl name))
-
-(defun wt-temp (temp)
-  (wt "T" temp))
-
 (defun wt-fixnum (value &optional vv)
   (declare (ignore vv))
   (princ value *compiler-output1*)
@@ -178,13 +162,13 @@
          (wt "(" vv "->symbol.gfdef)")))
       (t
        ;; #'(SETF symbol)
-       (let ((set-loc (assoc name *setf-definitions*)))
-         (unless set-loc
+       (let ((setf-loc (assoc name *setf-definitions*)))
+         (unless setf-loc
            (let* ((setf-vv (data-empty-loc*))
                   (name-vv (get-object name)))
-             (setf set-loc (list name setf-vv name-vv))
-             (push set-loc *setf-definitions*)))
-         (wt "ECL_CONS_CAR(" (second set-loc) ")"))))))
+             (setf setf-loc (list name setf-vv name-vv))
+             (push setf-loc *setf-definitions*)))
+         (wt "ECL_CONS_CAR(" (second setf-loc) ")"))))))
 
 (defun environment-accessor (fun)
   (let* ((env-var (env-var-name *env-lvl*))
@@ -369,7 +353,7 @@
       (case c
         (#\@
          (let ((object (read s)))
-           (unless (and (consp object) (eq (car object) 'RETURN))
+           (unless (and (consp object) (eq (car object) 'CL:RETURN))
              (cmperr "Used @~s in C-INLINE form. Expected syntax is @(RETURN ...)." object))
            (if (eq output-vars 'VALUES)
                (cmperr "Used @(RETURN ...) in a C-INLINE form with no output values.")
@@ -399,61 +383,66 @@
 ;;; SET-LOC
 ;;;
 
-(defun set-unknown-loc (loc)
-  (declare (ignore loc))
-  (unknown-location 'set-loc *destination*))
+(defun set-unknown-loc (destination loc)
+  (unknown-location 'set-loc destination))
 
-(defun set-loc (loc &aux fd)
-  (let ((destination *destination*))
-    (cond ((eq destination loc))
-          ((symbolp destination)
-           (funcall (gethash destination *set-loc-dispatch-table*
-                             'set-unknown-loc)
-                    loc))
-          ((var-p destination)
-           (set-var loc destination))
-          ((vv-p destination)
-           (set-vv loc destination))
-          ((atom destination)
-           (unknown-location 'set-loc destination))
-          (t
-           (let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
-             (if fd
-                 (apply fd loc (rest destination))
-                 (progn
-                   (wt-nl)
-                   (wt-loc destination) (wt " = ")
-                   (wt-coerce-loc (loc-representation-type *destination*) loc)
-                   (wt ";"))))))))
+(defun set-loc (destination loc &aux fd)
+  (cond ((eq destination loc))
+        ((symbolp destination)
+         (funcall (gethash destination *set-loc-dispatch-table* 'set-unknown-loc)
+                  loc))
+        ((var-p destination)
+         (set-var loc destination))
+        ((vv-p destination)
+         (set-vv loc destination))
+        ((atom destination)
+         (unknown-location 'set-loc destination loc))
+        (t
+         (ext:if-let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
+           (apply fd loc (rest destination))
+           (progn
+             (wt-nl)
+             (wt-loc destination) (wt " = ")
+             (wt-coerce-loc (loc-representation-type *destination*) loc)
+             (wt ";"))))))
 
 (defun set-the-loc (loc type orig-loc)
   (declare (ignore type))
-  (let ((*destination* orig-loc))
-    (set-loc loc)))
+  (set-loc orig-loc loc))
                  
-(defun set-values-loc (loc)
-  (cond ((eq loc 'VALUES))
+(defun set-valuez-loc (loc)
+  (cond ((eq loc 'VALUEZ))
         ((uses-values loc)
          (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";"))
         (t
-         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc)
-         (wt ";")
+         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";")
          (wt-nl "cl_env_copy->nvalues = 1;"))))
 
 (defun set-value0-loc (loc)
   (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
 
-(defun set-return-loc (loc)
-  (cond ((or (eq loc 'VALUES) (uses-values loc))
+(defun set-leave-loc (loc)
+  (cond ((or (eq loc 'VALUEZ) (uses-values loc))
          (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
         ((eq loc 'VALUE0)
          (wt-nl "cl_env_copy->nvalues = 1;"))
-        ((eq loc 'RETURN))
+        ((eq loc 'LEAVE))
         (t
          (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")
          (wt-nl "cl_env_copy->nvalues = 1;"))))
 
-(defun set-trash-loc (loc)
+(defun set-trash-loc (loc &rest args)
+  (declare (ignore args))
   (when (loc-with-side-effects-p loc)
     (wt-nl loc ";")
     t))
+
+;;;
+;;; Foreign data
+;;;
+
+(defun wt-ffi-data-ref (data ffi-tag)
+  (wt "ecl_foreign_data_ref_elt(&" data "," ffi-tag ")"))
+
+(defun wt-ffi-data-set (value data ffi-tag)
+  (wt "ecl_foreign_data_set_elt(&" data "," ffi-tag "," value ");"))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
index 14c555f41..78e00de5d 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
@@ -1,62 +1,68 @@
 (in-package #:compiler)
 
 
+
+(defun wt-print-header (source)
+  (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
+  #-ecl-min
+  (multiple-value-bind (second minute hour day month year)
+      (get-decoded-time)
+    (declare (ignore second))
+    (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
+    (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
+  (wt-comment-nl "Source: ~A" source))
+
+(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
+  (with-cxx-env ()
+    ;; After this step we still can add new objects, but objects that are
+    ;; already stored in VV or VVtemp must not change the location.
+    (optimize-cxx-data *referenced-objects*)
+    (setq *compiler-phase* 't2)
+    (with-open-file (*compiler-output1* c-pathname :direction :output
+                                                   :if-does-not-exist :create
+                                                   :if-exists :supersede)
+      (with-open-file (*compiler-output2* h-pathname :direction :output
+                                                     :if-does-not-exist :create
+                                                     :if-exists :supersede)
+        (wt-print-header source)
+        (wt-nl1 "#include " *cmpinclude*)
+        (ctop-write init-name h-pathname data-pathname)
+        (terpri *compiler-output1*)
+        (terpri *compiler-output2*)))
+    (data-c-dump data-pathname)))
+
 ;;;;  CMPTOP  --  Compiler top-level.
 
 (defun t2expr (form)
-  (when form
-    (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
-      (let ((*compile-file-truename* (c1form-file form))
-            (*compile-file-position* (c1form-file-position form))
-            (*current-toplevel-form* (c1form-form form))
-            (*current-form* (c1form-form form))
-            (*cmp-env* (c1form-env form)))
-        (apply def form (c1form-args form)))
-      (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form))))
+  (check-type form c1form)
+  (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
+    (let ((*compile-file-truename* (c1form-file form))
+          (*compile-file-position* (c1form-file-position form))
+          (*current-toplevel-form* (c1form-form form))
+          (*current-form* (c1form-form form))
+          (*cmp-env* (c1form-env form)))
+      (apply def form (c1form-args form)))
+    (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))
 
-(defun emit-local-funs ()
+(defun emit-functions (*compiler-output1*)
   (declare (si::c-local))
   ;; Local functions and closure functions
   (do ((*compile-time-too* nil)
-       (*compile-toplevel* nil))
-      ;; repeat until t3local-fun generates no more
-      ((eq *emitted-local-funs* *local-funs*))
-    ;; scan *local-funs* backwards
-    (do ((lfs *local-funs* (cdr lfs)))
-        ((eq (cdr lfs) *emitted-local-funs*)
-         (setq *emitted-local-funs* lfs)
-         (locally (declare (notinline t3local-fun))
+       (*compile-toplevel* nil)
+       (*emitted-functions* nil))
+      ;; repeat until t3function generates no more
+      ((eq *emitted-functions* *functions*))
+    ;; scan *functions* backwards
+    (do ((lfs *functions* (cdr lfs)))
+        ((eq (cdr lfs) *emitted-functions*)
+         (setq *emitted-functions* lfs)
+         (locally (declare (notinline t3function))
            ;; so disassemble can redefine it
-           (t3local-fun (first lfs)))))))
+           (t3function (first lfs)))))))
 
-(defun ctop-write (name h-pathname data-pathname
-                        &aux def top-output-string
-                        (*volatile* "volatile "))
-
-  (wt-nl "#include \"" (brief-namestring h-pathname) "\"")
-
-  ;; VV might be needed by functions in CLINES.
-  (wt-nl-h "#ifdef ECL_DYNAMIC_VV")
-  (wt-nl-h "static cl_object *VV;")
-  (wt-nl-h "#else")
-  (wt-nl-h "static cl_object VV[VM];")
-  (wt-nl-h "#endif")
-  (output-clines *compiler-output2*)
-
-  (wt-nl-h "#ifdef __cplusplus")
-  (wt-nl-h "extern \"C\" {")
-  (wt-nl-h "#endif")
-  ;;; Initialization function.
+(defun emit-entry-fun (name *compiler-output1*)
   (let* ((*opened-c-braces* 0)
-         (*aux-closure* nil)
-         (c-output-file *compiler-output1*)
-         (*compiler-output1* (make-string-output-stream))
-         (*emitted-local-funs* nil)
-         (*compiler-declared-globals* (make-hash-table)))
-    (wt-nl "#include \"" (brief-namestring data-pathname) "\"")
-    (wt-nl "#ifdef __cplusplus")
-    (wt-nl "extern \"C\"")
-    (wt-nl "#endif")
+         (*aux-closure* nil))
     (wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)")
     (wt-nl-open-brace)
     (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
@@ -85,19 +91,37 @@
     ;; With this we ensure creating a constant with the tag
     ;; and the initialization file
     (wt-nl "Cblock->cblock.data_text = (const cl_object *)\"" (init-name-tag name) "\";")
-
     (wt-nl "VVtemp = Cblock->cblock.temp_data;")
-
     (wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
-
     (dolist (form *make-forms*)
-      (emit-toplevel-form form c-output-file))
+      (emit-toplevel-form form))
     (dolist (form *top-level-forms*)
-      (emit-toplevel-form form c-output-file))
+      (emit-toplevel-form form))
+    ;; We process top-level forms before functions to update their
+    ;; environments. Then we emit functions before top level forms.
+    (wt-nl-close-many-braces 0)))
 
-    (wt-nl-close-many-braces 0)
-    (setq top-output-string (get-output-stream-string *compiler-output1*)))
+(defun ctop-write (init-name h-pathname data-pathname
+                   &aux def top-output-string (*volatile* "volatile "))
+  (wt-nl "#include \"" (brief-namestring h-pathname) "\"")
 
+  ;; VV might be needed by functions in CLINES.
+  (wt-nl-h "#ifdef ECL_DYNAMIC_VV")
+  (wt-nl-h "static cl_object *VV;")
+  (wt-nl-h "#else")
+  (wt-nl-h "static cl_object VV[VM];")
+  (wt-nl-h "#endif")
+  (output-clines *compiler-output2*)
+
+  (wt-nl-h "#ifdef __cplusplus")
+  (wt-nl-h "extern \"C\" {")
+  (wt-nl-h "#endif")
+  ;;; We rebind the output to ensure that the initialization function is
+  ;;; processed first and added last.
+  (let ((output (make-string-output-stream)))
+    (emit-entry-fun init-name output)
+    (emit-functions *compiler-output1*)
+    (setq top-output-string (get-output-stream-string output)))
   ;; Declarations in h-file.
   (wt-nl-h "static cl_object Cblock;")
   (let ((num-objects (data-size)))
@@ -114,7 +138,7 @@
 
   (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 ",ECL_T);"))
+        do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);"))
 
   (wt-nl-h "#ifdef __cplusplus")
   (wt-nl-h "}")
@@ -138,9 +162,13 @@
     (dolist (x *callbacks*)
       (apply #'t3-defcallback x)))
 
+  (wt-nl "#include \"" (brief-namestring data-pathname) "\"")
+  (wt-nl "#ifdef __cplusplus")
+  (wt-nl "extern \"C\"")
+  (wt-nl "#endif")
   (wt-nl top-output-string))
 
-(defun emit-toplevel-form (form c-output-file)
+(defun emit-toplevel-form (form)
   (declare (si::c-local))
   (let ((*ihs-used-p* nil)
         (*max-lex* 0)
@@ -164,14 +192,10 @@
               (plusp *max-temp*)
               (plusp *max-env*)
               *ihs-used-p*)
-          (progn
-            (wt-nl-open-brace)
+          (with-lexical-scope ()
             (wt-function-locals)
-            (write-sequence body *compiler-output1*)
-            (wt-nl-close-brace))
-          (write-sequence body *compiler-output1*)))
-    (let ((*compiler-output1* c-output-file))
-      (emit-local-funs))))
+            (write-sequence body *compiler-output1*))
+          (write-sequence body *compiler-output1*)))))
 
 (defun t2compiler-let (c1form symbols values body)
   (declare (ignore c1form))
@@ -218,99 +242,34 @@
 
 (defun t2ordinary (c1form form)
   (declare (ignore c1form))
-  (let* ((*exit* (next-label))
-         (*unwind-exit* (list *exit*))
-         (*destination* 'TRASH))
-    (c2expr form)
-    (wt-label *exit*)))
+  (with-exit-label (*exit*)
+    (let ((*destination* 'TRASH))
+      (c2expr form))))
 
 (defun t2load-time-value (c1form vv-loc form)
   (declare (ignore c1form))
-  (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
-         (*destination* vv-loc))
-    (c2expr form)
-    (wt-label *exit*)))
+  (with-exit-label (*exit*)
+    (let ((*destination* vv-loc))
+      (c2expr form))))
 
 (defun t2make-form (c1form vv-loc form)
   (declare (ignore c1form))
-  (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
-         (*destination* vv-loc))
-    (c2expr form)
-    (wt-label *exit*)))
+  (with-exit-label (*exit*)
+    (let ((*destination* vv-loc))
+      (c2expr form))))
 
 (defun t2init-form (c1form vv-loc form)
   (declare (ignore c1form vv-loc))
-  (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
-         (*destination* 'TRASH))
-    (c2expr form)
-    (wt-label *exit*)))
+  (with-exit-label (*exit*)
+    (let ((*destination* 'TRASH))
+      (c2expr form))))
 
-(defun locative-type-from-var-kind (kind)
-  (cdr (assoc kind
-              '((:object . "_ecl_object_loc")
-                (:fixnum . "_ecl_fixnum_loc")
-                (:char . "_ecl_base_char_loc")
-                (:float . "_ecl_float_loc")
-                (:double . "_ecl_double_loc")
-                (:long-double . "_ecl_long_double_loc")
-                #+complex-float (:csfloat . "_ecl_csfloat_loc")
-                #+complex-float (:cdfloat . "_ecl_cdfloat_loc")
-                #+complex-float (:clfloat . "_ecl_clfloat_loc")
-                #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
-                #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
-                #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")
-                ((special global closure lexical) . NIL)))))
-
-(defun build-debug-lexical-env (var-locations &optional first)
-  #-:msvc ;; FIXME! Problem with initialization of statically defined vectors
-  (let* ((filtered-locations '())
-         (filtered-codes '()))
-    ;; Filter out variables that we know how to store in the
-    ;; debug information table. This excludes among other things
-    ;; closures and special variables.
-    (loop for var in var-locations
-          for name = (let ((*package* (find-package "KEYWORD")))
-                       (format nil "\"~S\"" (var-name var)))
-          for code = (locative-type-from-var-kind (var-kind var))
-          for loc = (var-loc var)
-          when (and code (consp loc) (eq (first loc) 'LCL))
-          do (progn
-               (push (cons name code) filtered-codes)
-               (push loc filtered-locations)))
-    ;; Generate two tables, a static one with information about the
-    ;; variables, including name and type, and dynamic one, which is
-    ;; a vector of pointer to the variables.
-    (when filtered-codes
-      (setf *ihs-used-p* t)
-      (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
-      (loop for (name . code) in filtered-codes
-            for i from 0
-            do (wt-nl (if (zerop i) "{" ",{") name "," code "}"))
-      (wt "};")
-      (wt-nl "const cl_index _ecl_debug_info_raw[]={")
-      (wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),")
-             "(cl_index)(_ecl_descriptors)")
-      (loop for var-loc in filtered-locations
-            do (wt ",(cl_index)(&" var-loc ")"))
-      (wt "};")
-      (wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,"
-             (+ 2 (length filtered-locations))
-             ",,);")
-      (unless first
-        (wt-nl "ihs.lex_env = _ecl_debug_env;")))
-    filtered-codes))
-
-(defun pop-debug-lexical-env ()
-  (wt-nl "ihs.lex_env = _ecl_debug_env;"))
-
-(defun t3local-fun (fun)
+(defun t3function (fun)
   (declare (type fun fun))
-
   ;; Compiler note about compiling this function
   (when *compile-print*
     (ext:when-let ((name (or (fun-name fun) (fun-description fun))))
       (format t "~&;;; Emitting code for ~s.~%" name)))
-
   (let* ((lambda-expr (fun-lambda fun))
          (*cmp-env* (c1form-env lambda-expr))
          (*lcl* 0) (*temp* 0) (*max-temp* 0)
@@ -320,33 +279,33 @@
          (*max-env* *env*) (*env-lvl* 0)
          (*aux-closure* nil)
          (*level* (fun-lexical-levels fun))
-         (*exit* 'RETURN)
-         (*unwind-exit* '(RETURN))
-         (*destination* 'RETURN)
+         (*exit* 'LEAVE)
+         (*unwind-exit* '(LEAVE))
+         (*destination* *exit*)
          (*ihs-used-p* nil)
          (*opened-c-braces* 0)
          (*tail-recursion-info* fun)
+         (*tail-recursion-mark* nil)
          (*volatile* (c1form-volatile* lambda-expr)))
-    ;; Function declaration. Returns NIL if this function needs no body.
-    (when (t3local-fun-declaration fun)
-      (wt-nl-open-brace)
-      (let ((body (t3local-fun-body fun)))
-        (wt-function-locals (fun-closure fun))
-        (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
-        (when (eq (fun-closure fun) 'CLOSURE)
-          (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
-        (wt-nl "cl_object " *volatile* "value0;")
-        (when (policy-check-stack-overflow)
-          (wt-nl "ecl_cs_check(cl_env_copy,value0);"))
-        (when (eq (fun-closure fun) 'CLOSURE)
-          (t3local-fun-closure-scan fun))
-        (write-sequence body *compiler-output1*)
-        (wt-nl-close-many-braces 0)))))
+    (t3function-declaration fun)
+    (wt-nl-open-brace)
+    (let ((body (t3function-body fun)))
+      (wt-function-locals (fun-closure fun))
+      (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
+      (when (eq (fun-closure fun) 'CLOSURE)
+        (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
+      (wt-nl "cl_object " *volatile* "value0;")
+      (when (policy-check-stack-overflow)
+        (wt-nl "ecl_cs_check(cl_env_copy,value0);"))
+      (when (eq (fun-closure fun) 'CLOSURE)
+        (t3function-closure-scan fun))
+      (write-sequence body *compiler-output1*)
+      (wt-nl-close-many-braces 0))))
 
-(defun t3local-fun-body (fun)
+(defun t3function-body (fun)
   (let ((string (make-array 2048 :element-type 'character
-                            :adjustable t
-                            :fill-pointer 0)))
+                                 :adjustable t
+                                 :fill-pointer 0)))
     (with-output-to-string (*compiler-output1* string)
       (let ((lambda-expr (fun-lambda fun)))
         (c2lambda-expr (c1form-arg 0 lambda-expr)
@@ -361,23 +320,20 @@
                        (fun-keyword-type-check-forms fun))))
     string))
 
-(defun t3local-fun-declaration (fun)
+(defun t3function-declaration (fun)
   (declare (type fun fun))
   (wt-comment-nl (cond ((fun-global fun) "function definition for ~a")
                        ((eq (fun-closure fun) 'CLOSURE) "closure ~a")
                        (t "local function ~a"))
                  (or (fun-name fun) (fun-description fun) 'CLOSURE))
-  (when (fun-shares-with fun)
-    (wt-comment-nl "... shares definition with ~a" (fun-name (fun-shares-with fun)))
-    (return-from t3local-fun-declaration nil))
   (let* ((comma "")
          (lambda-expr (fun-lambda fun))
          (volatile (c1form-volatile* lambda-expr))
          (lambda-list (c1form-arg 0 lambda-expr))
          (requireds (loop
-                       repeat si::c-arguments-limit
-                       for arg in (car lambda-list)
-                       collect (next-lcl (var-name arg))))
+                      repeat si::c-arguments-limit
+                      for arg in (car lambda-list)
+                      collect (next-lcl (var-name arg))))
          (narg (fun-needs-narg fun)))
     (let ((cmp-env (c1form-env lambda-expr)))
       (wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D "
@@ -401,15 +357,14 @@
       (wt comma "volatile cl_object *lex" n)
       (setf comma ", "))
     (loop for lcl in (setf (fun-required-lcls fun) requireds)
-       do (wt-h comma "cl_object " volatile)
-         (wt comma "cl_object " volatile lcl)
-         (setf comma ", "))
+          do (wt-h comma "cl_object " volatile)
+             (wt comma "cl_object " volatile lcl)
+             (setf comma ", "))
     (when narg
       (wt-h ", ...")
       (wt ", ..."))
     (wt-h ");")
-    (wt ")"))
-  t)
+    (wt ")")))
 
 (defun fun-closure-variables (fun)
   (sort (remove-if
@@ -434,7 +389,7 @@
       (fun-level fun)
       0))
 
-(defun t3local-fun-closure-scan (fun)
+(defun t3function-closure-scan (fun)
   (let ((clv-used (fun-closure-variables fun)))
     (wt-nl "/* Scanning closure data ... */")
     (do ((n (1- (fun-env fun)) (1- n))
@@ -477,29 +432,30 @@
                              cfun (fun-file-position fun))))
           (format stream "~%};")))))
 
-(defun t2fset (c1form &rest args)
-  (declare (ignore args))
-  (t2ordinary nil c1form))
-
-(defun c2fset (c1form fun fname macro pprint c1forms)
-  (declare (ignore pprint))
-  (when (fun-no-entry fun)
-    (wt-nl "(void)0; "
-           (format nil "/* No entry created for ~A */" (fun-name fun)))
-    ;; FIXME! Look at C2LOCALS!
-    (new-local fun)
-    (return-from c2fset))
-  (unless (and (not (fun-closure fun))
-               (eq *destination* 'TRASH))
-    (return-from c2fset
-      (c2call-global c1form 'SI:FSET c1forms)))
+(defun wt-install-function (fname fun macro-p)
   (let ((*inline-blocks* 0)
         (loc (data-empty-loc*)))
     (push (list loc fname fun) *global-cfuns-array*)
     ;; FIXME! Look at C2LOCALS!
-    (new-local fun)
-    (if macro
+    (update-function-env fun)
+    (if macro-p
         (wt-nl "ecl_cmp_defmacro(" loc ");")
         (wt-nl "ecl_cmp_defun(" loc ");"))
     (wt-comment (loc-immediate-value fname))
     (close-inline-blocks)))
+
+(defun t2fset (c1form &rest args)
+  (declare (ignore args))
+  (t2ordinary c1form c1form))
+
+(defun c2fset (c1form fun fname macro-p pprint c1forms)
+  (declare (ignore pprint))
+  (when (fun-no-entry fun)
+    (wt-nl "(void)0; " (format nil "/* No entry created for ~A */" (fun-name fun)))
+    ;; FIXME! Look at C2LOCALS!
+    (update-function-env fun)
+    (return-from c2fset))
+  (if (and (not (fun-closure fun))
+           (eq *destination* 'TRASH))
+      (wt-install-function fname fun macro-p)
+      (c2call-global c1form 'SI:FSET c1forms)))
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp
index e9cd97f5e..dd8c58fa7 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp
@@ -20,16 +20,72 @@
              (local var))
     (let ((var1 (c1form-arg 0 form)))
       (declare (type var var1))
-      (when (and ;; Fixme! We should be able to replace variable
-             ;; even if they are referenced across functions.
-             ;; We just need to keep track of their uses.
-             (local var1)
-             (eq (unboxed var) (unboxed var1))
-             (not (var-changed-in-form-list var1 rest-forms)))
+      ;; FIXME We should be able to replace variable even if they are referenced
+      ;; across functions.  We just need to keep track of their uses.
+      (when (and (local var1)
+                 (eq (unboxed var) (unboxed var1))
+                 (not (var-changed-in-form-list var1 rest-forms)))
         (cmpdebug "Replacing variable ~a by its value" (var-name var))
         (nsubst-var var form)
         t))))
 
+(defun locative-type-from-var-kind (kind)
+  (cdr (assoc kind
+              '((:object . "_ecl_object_loc")
+                (:fixnum . "_ecl_fixnum_loc")
+                (:char . "_ecl_base_char_loc")
+                (:float . "_ecl_float_loc")
+                (:double . "_ecl_double_loc")
+                (:long-double . "_ecl_long_double_loc")
+                #+complex-float (:csfloat . "_ecl_csfloat_loc")
+                #+complex-float (:cdfloat . "_ecl_cdfloat_loc")
+                #+complex-float (:clfloat . "_ecl_clfloat_loc")
+                #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
+                #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
+                #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")
+                ((special global closure lexical) . NIL)))))
+
+(defun build-debug-lexical-env (var-locations &optional first)
+  #-:msvc ;; FIXME! Problem with initialization of statically defined vectors
+  (let* ((filtered-locations '())
+         (filtered-codes '()))
+    ;; Filter out variables that we know how to store in the debug information
+    ;; table. This excludes among other things closures and special variables.
+    (loop for var in var-locations
+          for name = (let ((*package* (find-package "KEYWORD")))
+                       (format nil "\"~S\"" (var-name var)))
+          for code = (locative-type-from-var-kind (var-kind var))
+          for loc = (var-loc var)
+          when (and code (consp loc) (eq (first loc) 'LCL))
+            do (progn
+                 (push (cons name code) filtered-codes)
+                 (push loc filtered-locations)))
+    ;; Generate two tables, a static one with information about the variables,
+    ;; including name and type, and dynamic one, which is a vector of pointer to
+    ;; the variables.
+    (when filtered-codes
+      (setf *ihs-used-p* t)
+      (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
+      (loop for (name . code) in filtered-codes
+            for i from 0
+            do (wt-nl (if (zerop i) "{" ",{") name "," code "}"))
+      (wt "};")
+      (wt-nl "const cl_index _ecl_debug_info_raw[]={")
+      (wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),")
+             "(cl_index)(_ecl_descriptors)")
+      (loop for var-loc in filtered-locations
+            do (wt ",(cl_index)(&" var-loc ")"))
+      (wt "};")
+      (wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,"
+             (+ 2 (length filtered-locations))
+             ",,);")
+      (unless first
+        (wt-nl "ihs.lex_env = _ecl_debug_env;")))
+    filtered-codes))
+
+(defun pop-debug-lexical-env ()
+  (wt-nl "ihs.lex_env = _ecl_debug_env;"))
+
 (defun c2let* (c1form vars forms body
                &aux
                (*volatile* (c1form-volatile* c1form))
@@ -76,14 +132,14 @@
   ;; Optionally register the variables with the IHS frame for debugging
   (if (policy-debug-variable-bindings)
       (let ((*unwind-exit* *unwind-exit*))
-        (wt-nl-open-brace)
-        (let* ((env (build-debug-lexical-env vars)))
-          (when env (push 'IHS-ENV *unwind-exit*))
-          (c2expr body)
-          (wt-nl-close-brace)
-          (when env (pop-debug-lexical-env))))
+        (with-lexical-scope ()
+          (ext:if-let ((env (build-debug-lexical-env vars)))
+            (progn
+              (push 'IHS-ENV *unwind-exit*)
+              (c2expr body)
+              (pop-debug-lexical-env))
+            (c2expr body))))
       (c2expr body))
-
   (close-inline-blocks))
 
 (defun c2multiple-value-bind (c1form vars init-form body)
@@ -94,16 +150,13 @@
          (*lcl* *lcl*)
          (labels nil)
          (env-grows nil)
-         (nr (make-lcl-var :type :int))
          (*inline-blocks* 0)
          min-values max-values)
-    (declare (ignore nr))
-    ;; 1) Retrieve the number of output values
+    ;; 1) Retrieve the number of output values.
     (multiple-value-setq (min-values max-values)
       (c1form-values-number init-form))
-
-    ;; 2) For all variables which are not special and do not belong to
-    ;;    a closure, make a local C variable.
+    ;; 2) For all variables which are not special and do not belong to a
+    ;;    closure, make a local C variable.
     (dolist (var vars)
       (declare (type var var))
       (let ((kind (local var)))
@@ -114,22 +167,18 @@
               (wt-nl (rep-type->c-name kind) " " *volatile* var ";")
               (wt-comment (var-name var)))
             (unless env-grows (setq env-grows (var-ref-ccb var))))))
-
     ;; 3) If there are closure variables, set up an environment.
     (when (setq env-grows (env-grows env-grows))
       (let ((env-lvl *env-lvl*))
         (maybe-open-inline-block)
         (wt-nl "volatile cl_object env" (incf *env-lvl*)
                " = env" env-lvl ";")))
-
-    ;; 4) Assign the values to the variables, compiling the form
-    ;;    and binding the variables in the process.
+    ;; 4) Assign the values to the variables, compiling the form and binding the
+    ;;    variables in the process.
     (do-m-v-setq vars init-form t)
-
-    ;; 5) Compile the body. If there are bindings of special variables,
-    ;;    these bindings are undone here.
+    ;; 5) Compile the body. If there are bindings of special variables, these
+    ;;    bindings are undone here.
     (c2expr body)
-
     ;; 6) Close the C expression.
     (close-inline-blocks)))
 
@@ -137,7 +186,7 @@
   (unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
 
 ;;; When LOC is not NIL, then the variable is a constant.
-(defun c2var (c1form var loc)
+(defun c2variable (c1form var loc)
   (unwind-exit (precise-loc-type
                 (if (and loc (not (numberp (vv-location loc))))
                     loc
@@ -160,14 +209,13 @@
          (lcl (next-lcl))
          (sym-loc (make-lcl-var))
          (val-loc (make-lcl-var)))
-    (wt-nl-open-brace)
-    (wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
-    (let ((*destination* sym-loc)) (c2expr* symbols))
-    (let ((*destination* val-loc)) (c2expr* values))
-    (let ((*unwind-exit* (cons lcl *unwind-exit*)))
-      (wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
-      (c2expr body)
-      (wt-nl-close-brace))))
+    (with-lexical-scope ()
+      (wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
+      (let ((*destination* sym-loc)) (c2expr* symbols))
+      (let ((*destination* val-loc)) (c2expr* values))
+      (let ((*unwind-exit* (cons lcl *unwind-exit*)))
+        (wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
+        (c2expr body)))))
 
 (defun c2psetq (c1form vrefs forms
                 &aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*))
@@ -195,8 +243,10 @@
                 (let ((*destination* (make-temp-var)))
                   (c2expr* form)
                   (push (cons var *destination*) saves)))))
-        (let ((*destination* var)) (c2expr* form))))
-  (dolist (save saves) (set-var (cdr save) (car save)))
+        (let ((*destination* var))
+          (c2expr* form))))
+  (dolist (save saves)
+    (set-var (cdr save) (car save)))
   (wt-nl-close-many-braces braces)
   (unwind-exit *vv-nil*))
 
@@ -313,7 +363,7 @@
     (declare (ignore max-values))
 
     ;; We save the values in the value stack + value0
-    (let ((*destination* 'RETURN))
+    (let ((*destination* 'LEAVE))
       (c2expr* form))
 
     ;; At least we always have NIL value0
@@ -322,29 +372,28 @@
     (let* ((*lcl* *lcl*)
            (useful-extra-vars (some #'useful-var-p (nthcdr min-values vars)))
            (nr (make-lcl-var :type :int)))
-      (wt-nl-open-brace)
-      (when useful-extra-vars
-        ;; Make a copy of env->nvalues before assigning to any variables
-        (wt-nl "const int " nr " = cl_env_copy->nvalues;"))
+      (with-lexical-scope ()
+        (when useful-extra-vars
+          ;; Make a copy of env->nvalues before assigning to any variables
+          (wt-nl "const int " nr " = cl_env_copy->nvalues;"))
 
-      ;; We know that at least MIN-VALUES variables will get a value
-      (dotimes (i min-values)
-        (when vars
-          (let ((v (pop vars))
-                (loc (values-loc-or-value0 i)))
-            (bind-or-set loc v use-bind))))
+        ;; We know that at least MIN-VALUES variables will get a value
+        (dotimes (i min-values)
+          (when vars
+            (let ((v (pop vars))
+                  (loc (values-loc-or-value0 i)))
+              (bind-or-set loc v use-bind))))
 
-      ;; Assign to other variables only when the form returns enough values
-      (when useful-extra-vars
-        (let ((tmp (make-lcl-var)))
-          (wt-nl "cl_object " tmp ";")
-          (loop for v in vars
-             for i from min-values
-             for loc = (values-loc-or-value0 i)
-             do (when (useful-var-p v)
-                  (wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
-                  (bind-or-set tmp v use-bind)))))
-      (wt-nl-close-brace))
+        ;; Assign to other variables only when the form returns enough values
+        (when useful-extra-vars
+          (let ((tmp (make-lcl-var)))
+            (wt-nl "cl_object " tmp ";")
+            (loop for v in vars
+                  for i from min-values
+                  for loc = (values-loc-or-value0 i)
+                  do (when (useful-var-p v)
+                       (wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
+                       (bind-or-set tmp v use-bind)))))))
     'VALUE0))
 
 (defun c2multiple-value-setq (c1form vars form)
@@ -361,8 +410,7 @@
        (if (safe-compile)
            (wt "ecl_cmp_symbol_value(cl_env_copy," var-loc ")")
            (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")")))
-      (t (wt var-loc))
-      )))
+      (t (wt var-loc)))))
 
 (defun set-var (loc var &aux (var-loc (var-loc var))) ;  ccb
   (unless (var-p var)
@@ -389,10 +437,26 @@
      (wt #\;))
     ))
 
+(defun wt-lcl (lcl)
+  (unless (numberp lcl)
+    (baboon :format-control "wt-lcl: ~s NaN"
+            :format-arguments (list lcl)))
+  (wt "v" lcl))
+
+(defun wt-lcl-loc (lcl &optional type name)
+  (declare (ignore type))
+  (unless (numberp lcl)
+    (baboon :format-control "wt-lcl-loc: ~s NaN"
+            :format-arguments (list lcl)))
+  (wt "v" lcl name))
+
 (defun wt-lex (lex)
   (if (consp lex)
       (wt "lex" (car lex) "[" (cdr lex) "]")
       (wt-lcl lex)))
 
+(defun wt-temp (temp)
+  (wt "T" temp))
+
 ;;; reference to variable of inner closure.
 (defun wt-env (clv) (wt "ECL_CONS_CAR(CLV" clv ")"))
diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp
index 0f13def22..c467ffdce 100644
--- a/src/cmp/cmpfun.lsp
+++ b/src/cmp/cmpfun.lsp
@@ -14,6 +14,9 @@
 
 (in-package #:compiler)
 
+(defun register-function (fun)
+  (push fun *functions*))
+
 (defun child-function-p (presumed-parent fun)
   (declare (optimize speed))
   (loop for real-parent = (fun-parent fun)
@@ -86,7 +89,6 @@
             (setf (var-ref-clb var) nil
                   (var-ref-ccb var) t
                   (var-kind var) 'CLOSURE
-                  (var-loc var) 'OBJECT
                   to-be-updated
                   (prepend-new (var-functions-reading var)
                                (prepend-new (var-functions-setting var)
diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp
index 526f4ec59..73cc7627b 100644
--- a/src/cmp/cmpglobals.lsp
+++ b/src/cmp/cmpglobals.lsp
@@ -65,6 +65,7 @@ running the compiler. It may be updated by running ")
 ;;; List of callbacks to be generated
 ;;;
 (defvar *callbacks* nil)
+(defvar *functions* nil)
 
 ;;; --cmpc-machine.lsp, cmpffi.lsp ---
 (defvar *machine* nil)
@@ -123,10 +124,10 @@ variable, block, tag or function object at the end.")
 only be altered by DECLAIM forms and it is used to initialize the
 value of *CMP-ENV*.")
 
-;;; --cmplog.lsp--
+;;; --cmplocs.lsp--
 ;;;
-;;; Destination of output of different forms. See cmploc.lsp for types
-;;; of destinations.
+;;; Destination of output of different forms. See cmplocs.lsp for types of
+;;; destinations.
 ;;;
 (defvar *destination*)
 
@@ -238,6 +239,7 @@ be deleted if they have been opened with LoadLibrary.")
     (*compiler-in-use* t)
     (*compiler-phase* 't1)
     (*callbacks* nil)
+    (*functions* nil)
     (*cmp-env-root* (copy-tree *cmp-env-root*))
     (*cmp-env* nil)
     (*load-objects* (make-hash-table :size 128 :test #'equal))
diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp
index bb247b857..3b00d68b1 100644
--- a/src/cmp/cmplocs.lsp
+++ b/src/cmp/cmplocs.lsp
@@ -85,41 +85,34 @@
            (otherwise :object)))))
 
 (defun loc-with-side-effects-p (loc &aux name)
-  (cond ((var-p loc)
-         (and (global-var-p loc)
-              (policy-global-var-checking)))
-        ((atom loc)
-         nil)
-        ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT CALL-STACK)
-                 :test #'eq)
-         t)
-        ((eq name 'cl:THE)
-         (loc-with-side-effects-p (third loc)))
-        ((eq name 'cl:FDEFINITION)
-         (policy-global-function-checking))
-        ((eq name 'ffi:C-INLINE)
-         (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES
-             (fifth loc)))))             ;; or side effects
+  (when (atom loc)
+    (return-from loc-with-side-effects-p
+      (and (var-p loc)
+           (global-var-p loc)
+           (policy-global-var-checking))))
+  (case (first loc)
+    ((CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) T)
+    (CL:THE (loc-with-side-effects-p (third loc)))
+    (CL:FDEFINITION (policy-global-function-checking))
+    ;; Uses VALUES or has side effects.
+    (FFI:C-INLINE (or (eq (sixth loc) 'CL:VALUES) (fifth loc)))
+    (otherwise NIL)))
 
 (defun loc-refers-to-special-p (loc)
-  (cond ((var-p loc)
-         (member (var-kind loc) '(SPECIAL GLOBAL)))
-        ((atom loc)
-         nil)
-        ((eq (first loc) 'THE)
-         (loc-refers-to-special-p (third loc)))
-        ((eq (setf loc (first loc)) 'BIND)
-         t)
-        ((eq loc 'ffi:C-INLINE)
-         t)                             ; We do not know, so guess yes
-        (t nil)))
+  (when (atom loc)
+    (return-from loc-refers-to-special-p
+      (and (var-p loc)
+           (member (var-kind loc) '(SPECIAL GLOBAL)))))
+  (case (first loc)
+    (CL:THE (loc-refers-to-special-p (third loc)))
+    (BIND T)
+     ;; We do not know, so guess yes.
+    (FFI:C-INLINE T)
+    (otherwise NIL)))
 
 ;;; Valid locations are:
-;;;     NIL
-;;;     T
-;;;     fixnum
 ;;;     VALUE0
-;;;     VALUES
+;;;     VALUEZ
 ;;;     var-object
 ;;;     a string                        designating a C expression
 ;;;     ( VALUE i )                     VALUES(i)
@@ -144,22 +137,22 @@
 
 ;;; Valid *DESTINATION* locations are:
 ;;;
-;;;     VALUE0
-;;;     RETURN                          Object returned from current function.
+;;;     var-object                      Variable
+;;;     loc-object                      VV Location
 ;;;     TRASH                           Value may be thrown away.
-;;;     VALUES                          Values vector.
-;;;     var-object
-;;;     ( LCL lcl )
-;;;     ( LEX lex-address )
+;;;     LEAVE                           Object returned from current function.
+;;;     VALUEZ                          Values vector.
+;;;     VALUE0
+;;;     ( VALUE i )                     Nth value
 ;;;     ( BIND var alternative )        Alternative is optional
 ;;;     ( JUMP-TRUE label )
 ;;;     ( JUMP-FALSE label )
 
 (defun tmp-destination (loc)
   (case loc
-    (VALUES 'VALUES)
+    (VALUEZ 'VALUEZ)
     (TRASH 'TRASH)
-    (T 'RETURN)))
+    (T 'LEAVE)))
 
 (defun precise-loc-type (loc new-type)
   (if (subtypep (loc-type loc) new-type)
@@ -174,7 +167,7 @@
          t)
         ((vv-p loc)
          t)
-        ((member loc '(value0 values va-arg cl-va-arg))
+        ((member loc '(VALUE0 VALUEZ VA-ARG CL-VA-ARG))
          nil)
         ((atom loc)
          (baboon :format-control "Unknown location ~A found in C1FORM"
diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp
index e5ee240e0..f7000b155 100644
--- a/src/cmp/cmpmain.lsp
+++ b/src/cmp/cmpmain.lsp
@@ -284,7 +284,7 @@ from the C language code.  NIL means \"do not create the file\"."
          (*compiler-output2* (if h-file
                                  (open h-file :direction :output :external-format :default)
                                  null-stream))
-         (t3local-fun (symbol-function 'T3LOCAL-FUN))
+         (t3function (symbol-function 'T3FUNCTION))
          (compiler-conditions nil)
          (*cmp-env-root* *cmp-env-root*))
     (with-compiler-env (compiler-conditions)
@@ -292,10 +292,10 @@ from the C language code.  NIL means \"do not create the file\"."
         (setf disassembled-form (set-closure-env disassembled-form lexenv *cmp-env-root*))
         (unwind-protect
              (progn
-               (setf (symbol-function 'T3LOCAL-FUN)
+               (setf (symbol-function 'T3FUNCTION)
                      #'(lambda (&rest args)
                          (let ((*compiler-output1* *standard-output*))
-                           (apply t3local-fun args))))
+                           (apply t3function args))))
                (compiler-pass1 disassembled-form)
                (compiler-pass/propagate-types)
                (optimize-cxx-data *referenced-objects*)
@@ -304,7 +304,7 @@ from the C language code.  NIL means \"do not create the file\"."
                            (if data-file data-file ""))
                (when data-file
                  (data-c-dump data-file)))
-          (setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
+          (setf (symbol-function 'T3FUNCTION) t3function)
           (when h-file (close *compiler-output2*))))))
   nil)
 
diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp
index c04e8f213..7b11df5c7 100644
--- a/src/cmp/cmppackage.lsp
+++ b/src/cmp/cmppackage.lsp
@@ -3,55 +3,54 @@
 
 ;;;;
 ;;;;  Copyright (c) 2009, Juan Jose Garcia-Ripoll
+;;;;  Copyright (c) 2023, Daniel Kochmański
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-;;;;
-;;;;  CMPPACKAGE -- Package definitions and exported symbols
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
 
-(defpackage #:c
-  (:nicknames #:compiler)
-  (:use #:cl)
-  (:import-from #:ext #:install-c-compiler)
+;;;;  CMPPACKAGE -- Package definitions and exported symbols
+
+(defpackage "C"
+  (:nicknames "ECL-CMP" "COMPILER")
+  (:local-nicknames ("OP" "ECL-CMP/OP"))
+  (:use "CL")
+  (:import-from "EXT" "INSTALL-C-COMPILER")
   (:export
    ;; Flags controlling the compiler behavior.
-   #:*compiler-break-enable*
-   #:*compile-print*
-   #:*compile-to-linking-call*
-   #:*compile-verbose*
-   #:*compiler-features*
-   #:*cc*
-   #:*cc-optimize*
-   #:*user-cc-flags*
-   #:*user-ld-flags*                    ; deprecated
-   #:*user-linker-flags*
-   #:*user-linker-libs*
-   #:*suppress-compiler-messages*
+   "*COMPILER-BREAK-ENABLE*"
+   "*COMPILE-PRINT*"
+   "*COMPILE-TO-LINKING-CALL*"
+   "*COMPILE-VERBOSE*"
+   "*COMPILER-FEATURES*"
+   "*CC*"
+   "*CC-OPTIMIZE*"
+   "*USER-CC-FLAGS*"
+   "*USER-LD-FLAGS*"                    ; deprecated
+   "*USER-LINKER-FLAGS*"
+   "*USER-LINKER-LIBS*"
+   "*SUPPRESS-COMPILER-MESSAGES*"
    ;; Build targets. BUILD-ECL is not defined, preasumbly it was meant
    ;; for cross compilation.
-   #:build-ecl
-   #:build-program
-   #:build-fasl
-   #:build-static-library
-   #:build-shared-library
+   "BUILD-ECL"
+   "BUILD-PROGRAM"
+   "BUILD-FASL"
+   "BUILD-STATIC-LIBRARY"
+   "BUILD-SHARED-LIBRARY"
    ;; Conditions (and their accessors).
-   #:compiler-warning
-   #:compiler-note
-   #:compiler-message
-   #:compiler-error
-   #:compiler-fatal-error
-   #:compiler-internal-error
-   #:compiler-undefined-variable
-   #:compiler-message-file
-   #:compiler-message-file-position
-   #:compiler-message-form
+   "COMPILER-WARNING"
+   "COMPILER-NOTE"
+   "COMPILER-MESSAGE"
+   "COMPILER-ERROR"
+   "COMPILER-FATAL-ERROR"
+   "COMPILER-INTERNAL-ERROR"
+   "COMPILER-UNDEFINED-VARIABLE"
+   "COMPILER-MESSAGE-FILE"
+   "COMPILER-MESSAGE-FILE-POSITION"
+   "COMPILER-MESSAGE-FORM"
    ;; Other operators.
-   #:install-c-compiler
-   #:update-compiler-features))
+   "INSTALL-C-COMPILER"
+   "UPDATE-COMPILER-FEATURES"))
+
+
 
 (ext:package-lock '#:cl nil)
diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp
index 67d4dafbb..51a5f3d91 100644
--- a/src/cmp/cmppass1-eval.lsp
+++ b/src/cmp/cmppass1-eval.lsp
@@ -26,9 +26,9 @@
                 (make-c1form* 'LOCATION :type (object-type form)
                                         :args (add-symbol form)))
                ((constantp form *cmp-env*)
-                (c1var form (c1constant-symbol-value form (symbol-value form))))
+                (c1variable form (c1constant-symbol-value form (symbol-value form))))
                (t
-                (c1var form nil))))
+                (c1variable form nil))))
         ((consp form)
          (cmpck (not (si:proper-list-p form))
                 "Improper list found in lisp form~%~A" form)
@@ -213,4 +213,4 @@
 ;;; if this occurred in a proclaimed fun.
 
 (defun c1values (args)
-  (make-c1form* 'VALUES :args (c1args* args)))
+  (make-c1form* 'CL:VALUES :args (c1args* args)))
diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp
index 768665b25..efc1ce341 100644
--- a/src/cmp/cmppass1-fun.lsp
+++ b/src/cmp/cmppass1-fun.lsp
@@ -49,8 +49,7 @@
       (dolist (def (nreverse defs))
         (let ((fun (first def)))
           ;; The closure type will be fixed later on by COMPUTE-...
-          (push (c1compile-function (rest def) :fun fun)
-                local-funs))))
+          (push (c1compile-function (rest def) :fun fun) local-funs))))
 
     ;; When we are in a LABELs form, we have to propagate the external
     ;; variables from one function to the other functions that use it.
diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp
index 387df0fc9..39c4580c6 100644
--- a/src/cmp/cmppass1-top.lsp
+++ b/src/cmp/cmppass1-top.lsp
@@ -29,46 +29,44 @@
                      (*current-form* form)
                      (*setjmps* 0))
   (setq form (chk-symbol-macrolet form))
-  (when (consp form)
-    (let ((fun (car form)) (args (cdr form)) fd)
-      (when (member fun *toplevel-forms-to-print*)
-        (print-current-form))
-      (cond
-        ((consp fun) (t1ordinary form))
-        ((not (symbolp fun))
-         (cmperr "~s is illegal function." fun))
-        ((eq fun 'QUOTE)
-         (t1ordinary 'NIL))
-        ((setq fd (gethash fun *t1-dispatch-table*))
-         (funcall fd args))
-        ((gethash fun *c1-dispatch-table*)
-         (t1ordinary form))
-        ((and (setq fd (cmp-compiler-macro-function fun))
-              (inline-possible fun)
-              (let ((success nil))
-                (multiple-value-setq (fd success)
-                  (cmp-expand-macro fd form))
-                success))
-         (when *compile-time-too*
-           ;; Ignore compiler macros during compile time evaluation
-           ;; (they may expand in ffi:c-inline which the bytecodes
-           ;; compiler can't execute).
-           (cmp-eval form))
-         (let ((*compile-time-too* nil))
-           (push 'macroexpand *current-toplevel-form*)
-           (t1expr* fd)))
-        ((setq fd (cmp-macro-function fun))
+  (unless (consp form)
+    (return-from t1expr* (t1ordinary 'NIL)))
+  (let ((fun (car form)) (args (cdr form)) fd)
+    (when (member fun *toplevel-forms-to-print*)
+      (print-current-form))
+    (cond
+      ((consp fun) (t1ordinary form))
+      ((not (symbolp fun))
+       (cmperr "~s is illegal function." fun))
+      ((eq fun 'QUOTE)
+       (t1ordinary 'NIL))
+      ((setq fd (gethash fun *t1-dispatch-table*))
+       (funcall fd args))
+      ((gethash fun *c1-dispatch-table*)
+       (t1ordinary form))
+      ((and (setq fd (cmp-compiler-macro-function fun))
+            (inline-possible fun)
+            (let ((success nil))
+              (multiple-value-setq (fd success)
+                (cmp-expand-macro fd form))
+              success))
+       (when *compile-time-too*
+         ;; Ignore compiler macros during compile time evaluation
+         ;; (they may expand in ffi:c-inline which the bytecodes
+         ;; compiler can't execute).
+         (cmp-eval form))
+       (let ((*compile-time-too* nil))
          (push 'macroexpand *current-toplevel-form*)
-         (t1expr* (cmp-expand-macro fd form)))
-        (t (t1ordinary form))))))
+         (t1expr* fd)))
+      ((setq fd (cmp-macro-function fun))
+       (push 'macroexpand *current-toplevel-form*)
+       (t1expr* (cmp-expand-macro fd form)))
+      (t (t1ordinary form)))))
 
 (defun t1/c1expr (form)
-  (cond ((not *compile-toplevel*)
-         (c1expr form))
-        ((atom form)
-         (t1ordinary form))
-        (t
-         (t1expr* form))))
+  (if (not *compile-toplevel*)
+      (c1expr form)
+      (t1expr* form)))
 
 (defun c1eval-when (args)
   (check-args-number 'EVAL-WHEN args 1)
@@ -141,7 +139,7 @@
            (setf loc (add-object (cmp-eval form)))))
     (make-c1form* 'LOCATION :type t :args loc)))
 
-;;; ----------------------------------------------------------------------
+;;; ----------------------------------------------------------------------------
 ;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a
 ;;; toplevel form and also allows optimizing calls to DEFUN or DEFMACRO which
 ;;; are not toplevel, but which create no closures.
@@ -152,9 +150,13 @@
 ;;; the compiler we do not know whether a function is a closure, hence the need
 ;;; for a c2fset.
 ;;;
-;;; We optimize (SYS:FSET #'(LAMBDA ...) ..) and also, accidentally,
-;;; (SYS:FSET (FLET ((FOO ...)) #'FOO) ...) which is to what LAMBDA gets
-;;; translated in c1function.
+;;; We optimize:
+;;;
+;;;     (SYS:FSET NAME #'(LAMBDA ...) ...)
+;;;
+;;; where LAMBDA is expanded by C1FUNCTION to:
+;;;
+;;;     (SYS:FSET NAME (FLET ((FOO ...)) #'FOO))
 ;;;
 (defun t1fset (args)
   (let ((form `(si::fset ,@args)))
@@ -180,12 +182,10 @@
                  (every #'global-var-p (fun-referenced-vars fun-object))
                  ;; Referencing the function variable
                  (eq (c1form-name form) 'VARIABLE)
-                 (eq (c1form-arg 0 form)
-                     (fun-var fun-object)))
+                 (eq (c1form-arg 0 form) (fun-var fun-object)))
             (when (fun-no-entry fun-object)
               (when macro
-                (cmperr "Declaration C-LOCAL used in macro ~a"
-                        (fun-name fun-object)))
+                (cmperr "Declaration C-LOCAL used in macro ~a." fname))
               (return-from c1fset
                 (make-c1form* 'SI:FSET :args fun-object nil nil nil nil)))
             (when (and (typep macro 'boolean)
diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp
index ecfa14519..bf573576f 100644
--- a/src/cmp/cmppass1-var.lsp
+++ b/src/cmp/cmppass1-var.lsp
@@ -243,7 +243,7 @@
                      :ref 0)))))
 
 ;;; When LOC is not NIL then we deal with a constant.
-(defun c1var (name loc)
+(defun c1variable (name loc)
   (let* ((var (c1vref name))
          (output (make-c1form* 'VARIABLE
                                :type (var-type var)
@@ -271,8 +271,7 @@
              ((CLOSURE))
              ((LEXICAL)
               (when cfb
-                (setf (var-ref-clb var) t
-                      (var-loc var) 'OBJECT)))
+                (setf (var-ref-clb var) t)))
              (t
               (when cfb
                 (cmperr "Variable ~A declared of C type cannot be referenced across function boundaries."
diff --git a/src/cmp/cmprefs.lsp b/src/cmp/cmprefs.lsp
index 008261956..43686b377 100644
--- a/src/cmp/cmprefs.lsp
+++ b/src/cmp/cmprefs.lsp
@@ -49,14 +49,7 @@
   (functions-setting nil)
   (functions-reading nil)
                 ;;; Functions in which the variable has been modified or read.
-  (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can
-                ;;; be allocated on the c-stack: OBJECT means
-                ;;; the variable is declared as OBJECT, and CLB means
-                ;;; the variable is referenced across Level Boundary and thus
-                ;;; cannot be allocated on the C stack.  Note that OBJECT is
-                ;;; set during variable binding and CLB is set when the
-                ;;; variable is used later, and therefore CLB may supersede
-                ;;; OBJECT.
+  (loc 'OBJECT) ;;; During Pass 1: OBJECT
                 ;;; During Pass 2:
                 ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
                 ;;;   the cvar for the C variable that holds the value.
@@ -122,8 +115,6 @@
   (no-entry nil)        ;;; NIL if declared as C-LOCAL. Then we create no
                         ;;; function object and the C function is called
                         ;;; directly
-  (shares-with nil)     ;;; T if this function shares the C code with another one.
-                        ;;; In that case we need not emit this one.
   closure               ;;; During Pass2, T if env is used inside the function
   var                   ;;; the variable holding the funob
   description           ;;; Text for the object, in case NAME == NIL.
@@ -159,7 +150,7 @@
   ref-clb               ;;; Unused (see blk-var).
   read-nodes            ;;; Unused (see blk-var).
 |#
-  exit                  ;;; Where to return.  A label.
+  exit                  ;;; Where to return. A label.
   destination           ;;; Where the value of the block to go.
   var                   ;;; Variable containing the block id and its references.
   (type '(VALUES &REST T)) ;;; Estimated type.
@@ -173,8 +164,7 @@
    ref-clb              ;;; Unused (see tag-var).
    read-nodes           ;;; Unused (see tag-var).
 |#
-  label                 ;;; Where to jump: a label.
-  unwind-exit           ;;; Where to unwind-no-exit.
+  jump                  ;;; Where to escape. A label.
   var                   ;;; Variable containing frame ID.
   index                 ;;; An integer denoting the label.
   )
diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp
index 6072ed6b8..b9e904b13 100644
--- a/src/cmp/cmptables.lsp
+++ b/src/cmp/cmptables.lsp
@@ -36,7 +36,6 @@
     (CL:FUNCTION        fname :single-valued)
     (LOCALS             local-fun-list body labels-p :pure)
     ;; Specialized accessors
-    (CL:RPLACD          (dest-c1form value-c1form) :side-effects)
     (SI:STRUCTURE-REF   struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
     (SI:STRUCTURE-SET   struct-c1form type-name slot-index value-c1form :side-effects)
     ;; Control structures
@@ -155,17 +154,15 @@
     ))
 
 (defconstant +set-loc-dispatch-alist+
-  '((bind . bind)
-    (jump-true . set-jump-true)
-    (jump-false . set-jump-false)
-
-    (cl:values . set-values-loc)
-    (value0 . set-value0-loc)
-    (cl:return . set-return-loc)
-    (trash . set-trash-loc)
-
+  '((bind   . bind)
     (cl:the . set-the-loc)
-    ))
+    (valuez . set-valuez-loc)
+    (value0 . set-value0-loc)
+    (leave  . set-leave-loc)
+    (trash  . set-trash-loc)
+    (jump-true  . set-trash-loc)
+    (jump-false . set-trash-loc)
+    (ffi-data-ref . wt-ffi-data-set)))
 
 (defconstant +wt-loc-dispatch-alist+
   '((call-normal . wt-call-normal)
@@ -184,11 +181,12 @@
     (make-cclosure . wt-make-closure)
 
     (si:structure-ref . wt-structure-ref)
+    (ffi-data-ref . wt-ffi-data-ref)
 
-    (cl:return . "value0")
-    (cl:values . "cl_env_copy->values[0]")
+    (leave . "value0")
     (va-arg . "va_arg(args,cl_object)")
     (cl-va-arg . "ecl_va_arg(args)")
+    (valuez . "cl_env_copy->values[0]")
     (value0 . "value0")))
 
 (defconstant +c2-dispatch-alist+
@@ -224,7 +222,7 @@
     (cl:tagbody . c2tagbody)
     (cl:go . c2go)
 
-    (variable . c2var)
+    (variable . c2variable)
     (location . c2location)
     (cl:setq . c2setq)
     (cl:progv . c2progv)
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index 6040d189a..38782729a 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -70,8 +70,8 @@
      (restart-case
          (handler-bind ((compiler-note #'handle-compiler-note)
                         (warning #'handle-compiler-warning)
-                        (compiler-error #'handle-compiler-error)
                         (compiler-internal-error #'handle-compiler-internal-error)
+                        (compiler-error #'handle-compiler-error)
                         (serious-condition #'handle-compiler-internal-error))
            (mp:with-lock (mp:+load-compile-lock+)
              (let ,+init-env-form+
@@ -489,3 +489,9 @@ comparing circular objects."
 
 (defun same-fname-p (name1 name2)
   (equal name1 name2))
+
+(defun emptyp (item)
+  (etypecase item
+    (list (null item))
+    (vector (zerop (length item)))
+    (hash-table (zerop (hash-table-count item)))))
diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp
index f7bbfc09a..323bc0d25 100644
--- a/src/cmp/cmpvar.lsp
+++ b/src/cmp/cmpvar.lsp
@@ -27,22 +27,6 @@
     (baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A"
             :format-arguments (list (var-name var) *current-form*))))
 
-#+not-used
-(defun discarded (var form body &aux last)
-  (labels ((last-form (x &aux (args (c1form-args x)))
-             (case (c1form-name x)
-               (PROGN
-                 (last-form (car (last (first args)))))
-               ((LET LET* FLET LABELS BLOCK CATCH)
-                (last-form (car (last args))))
-               (VARIABLE (c1form-arg 0 x))
-               (t x))))
-    (and (not (c1form-side-effects form))
-         (or (< (var-ref var) 1)
-             (and (= (var-ref var) 1)
-                  (eq var (last-form body))
-                  (eq 'TRASH *destination*))))))
-
 (defun nsubst-var (var form)
   (when (var-set-nodes var)
     (baboon :format-control "Cannot replace a variable that is to be changed"))
@@ -56,16 +40,6 @@
     (c1form-replace-with where form))
   (setf (var-ignorable var) 0))
 
-#+not-used
-(defun member-var (var list)
-  (let ((kind (var-kind var)))
-    (if (member kind '(SPECIAL GLOBAL))
-        (member var list :test
-                #'(lambda (v1 v2)
-                    (and (member (var-kind v2) '(SPECIAL GLOBAL))
-                         (eql (var-name v1) (var-name v2)))))
-        (member var list))))
-
 ;;;
 
 (defun make-var (&rest args)
diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h
index 235a1a97f..d9ec2820e 100644
--- a/src/h/bytecodes.h
+++ b/src/h/bytecodes.h
@@ -1,16 +1,13 @@
 /* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
 /* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
 
-/**********************************************************************
- ***
- ***  IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY
- ***             APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER
- ***             IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER
- ***             CODE.
- **********************************************************************/
-/*
- * See ecl/src/c/interpreter.d for a detailed explanation of all opcodes
- */
+/* -----------------------------------------------------------------------------
+ ***  IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY APPROPRIATE CHANGES
+ ***  IN THE INTERPRETER AND COMPILER IN PARTICULAR, IT MAY HURT THE THREADED
+ ***  INTERPRETER CODE.
+ ----------------------------------------------------------------------------- */
+
+/* See ecl/src/c/interpreter.d for a detailed explanation of all opcodes. */
 enum {
   OP_NOP,
   OP_QUOTE,
diff --git a/src/h/stacks.h b/src/h/stacks.h
index 761740f67..602c93e54 100755
--- a/src/h/stacks.h
+++ b/src/h/stacks.h
@@ -312,6 +312,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
         ecl_enable_interrupts_env(env)
 
 #define ecl_frs_pop(env) ((env)->frs_top--)
+#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n)
 
 /*******************
  * ARGUMENTS STACK