From fdd7fa13a67aa0bedfafd271d0f1063aeca9bd7b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Tue, 5 Dec 2023 09:12:35 +0100
Subject: [PATCH] cmp: codegen: incorporate into the exit manager

---
 src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 113 ++++-------------------
 src/cmp/cmppass3-codegen.lsp             |  88 ++++++++++++++++++
 2 files changed, 104 insertions(+), 97 deletions(-)

diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
index a3de9b049..99513fcba 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
@@ -35,21 +35,21 @@
           (t (baboon-exit-invalid *exit*)))))
 
 (defun unwind-jump (exit)
-  (%unwind (label-denv exit) *unwind-exit*)
-  (%goto exit)
+  (push-instruction :unwind (label-denv exit) *unwind-exit*)
+  (push-instruction :goto exit)
   (bir-return *bir* (exit-iblock exit)))
 
 (defun unwind-cont (exit)
-  (%unwind (label-denv exit) *unwind-exit*)
-  (%goto exit)
+  (push-instruction :unwind (label-denv exit) *unwind-exit*)
+  (push-instruction :goto exit)
   (bir-insert *bir* (exit-iblock exit)))
 
 (defun unwind-flee (exit kind)
-  (%escape exit kind)
+  (push-instruction :escape exit kind)
   (bir-escape *bir* (exit-iblock exit)))
 
 (defun unwind-cond (exit kind &rest args)
-  (%branch exit *unwind-exit* kind args)
+  (push-instruction :branch exit *unwind-exit* kind args)
   (bir-branch *bir* (exit-iblock exit))
   (bir-insert *bir* (make-iblock :cont)))
 
@@ -89,7 +89,7 @@
 ;;; #<label id used-p>  -> label (basic block leader)
 
 (defun compute-unwind (unwind-to unwind-from)
-  (declare (si::c-local))
+  ;; (declare (si::c-local))
   (unless (tailp unwind-to unwind-from)
     (baboon-unwind-invalid unwind-to unwind-from))
   (loop with bds-lcl = nil
@@ -127,10 +127,10 @@
   (declare (si::c-local))
   ;; *destination* must be either LEAVE or TRASH.
   (unless (member loc '(VALUEZ LEAVE))
-    (set-loc 'LEAVE loc)
+    (push-instruction :move 'LEAVE loc)
     (setf loc 'LEAVE))
-  (%unwind nil *unwind-exit*)
-  (%exit loc)
+  (push-instruction :unwind nil *unwind-exit*)
+  (push-instruction :exit loc)
   (bir-return *bir* (bir-leave *bir*)))
 
 (defun unwind-label (loc)
@@ -147,13 +147,13 @@
         ;; binding. Otherwise we set the destination /before/ the unwind.
         (let* ((*temp* *temp*)
                (temp (make-temp-var)))
-          (set-loc temp loc)
-          (%unwind exit-denv from)
-          (set-loc dest temp))
+          (push-instruction :move temp loc)
+          (push-instruction :unwind exit-denv from)
+          (push-instruction :move dest temp))
         (progn
-          (set-loc dest loc)
-          (%unwind exit-denv from)))
-    (%jump exit from)
+          (push-instruction :move dest loc)
+          (push-instruction :unwind exit-denv from)))
+    (push-instruction :jump exit from)
     (bir-insert *bir* (exit-iblock exit))))
 
 ;;; Conditional JUMP based on the value of *DESTINATION*. This allows FMLA to
@@ -183,84 +183,3 @@
              (if (labelp *exit*)
                  (unwind-label *vv-t*)
                  (unwind-leave *vv-t*)))))))))
-
-
-;;; Helper functions
-;;;
-;;; These functions will be moved to codegen.
-
-;;; INV this function arguments are procured by COMPUTE-UNWIND.
-(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.lcl_env = _ecl_debug_env;"))))
-
-(defun %unwind (into from)
-  (declare (si::c-local))
-  (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
-      (compute-unwind into from)
-    (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
-
-(defun %branch (exit from kind args)
-  (ecase kind
-    (:jump-t
-     (destructuring-bind (loc) args
-       (case (loc-host-type loc)
-         (:bool     (wt-nl "if (" loc ") "))
-         (:object   (wt-nl "if (" loc "!=ECL_NIL) "))
-         (otherwise (wt-nl "if ((" (coerce-loc :object loc) ")!=ECL_NIL) ")))))
-    (:jump-f
-     (destructuring-bind (loc) args
-       (case (loc-host-type loc)
-         (:bool     (wt-nl "if (!(" loc "))"))
-         (:object   (wt-nl "if (Null(" loc "))"))
-         (otherwise (wt-nl "if (Null(" (coerce-loc :object loc) "))")))))
-    (:jump-eq
-     (destructuring-bind (x y) args
-       (wt-nl "if (" (coerce-loc :object x) "==" (coerce-loc :object y) ") "))))
-  (wt-open-brace)
-  (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
-      (compute-unwind (label-denv exit) from)
-    (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
-    (wt-nl-go exit))
-  (wt-nl-close-brace))
-
-(defun %escape (exit kind)
-  ;; All these boil down to calling ecl_unwind which unwinds stacks dynamically.
-  ;; If we want to implement call/cc, then this is the place where we dispatch.
-  #+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");")
-  (ecase kind
-    (:go
-     ;; The second argument is passed as a value (index for jump).
-     (wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));"))
-    (:throw
-        ;; Unlike GO and RETURN-FROM, the destination is not known at compile time.
-        ;; TODO in some cases it is possible to prove the destination CATCH form.
-        (wt-nl "cl_throw(" exit ");"))
-    (:return-from
-     ;; The second argument is used only to signal the error.
-     (wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");"))))
-
-;;; JUMP is similar to %GOTO, but it allows a fallthough.
-(defun %jump (label from)
-  (unless (eq label (find-if #'labelp from))
-    (wt-nl-go label)))
-
-(defun %goto (label)
-  (wt-nl-go label))
-
-(defun %exit (loc)
-  (wt-nl "return " loc ";"))
diff --git a/src/cmp/cmppass3-codegen.lsp b/src/cmp/cmppass3-codegen.lsp
index b22a2cfdb..6f0bb87c4 100644
--- a/src/cmp/cmppass3-codegen.lsp
+++ b/src/cmp/cmppass3-codegen.lsp
@@ -7,3 +7,91 @@
                        (opcode (eql ,opcode))
                        (,instruction instruction))
      ,@body))
+
+(define-codegen (:cxx :move) (instruction)
+  (destructuring-bind (into from) (instruction-inputs instruction)
+    (set-loc into from)))
+
+
+;;; Unwinding
+
+;;; INV this function arguments are procured by COMPUTE-UNWIND.
+(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.lcl_env = _ecl_debug_env;"))))
+
+(define-codegen (:cxx :unwind) (instruction)
+  (destructuring-bind (into from) (instruction-inputs instruction)
+    (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
+        (compute-unwind into from)
+      (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p))))
+
+(define-codegen (:cxx :branch) (instruction)
+  (destructuring-bind (exit from kind args) (instruction-inputs instruction)
+    (ecase kind
+      (:jump-t
+       (destructuring-bind (loc) args
+         (case (loc-host-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) ")))))
+      (:jump-f
+       (destructuring-bind (loc) args
+         (case (loc-host-type loc)
+           (:bool     (wt-nl "if (!(" loc "))"))
+           (:object   (wt-nl "if (Null(" loc "))"))
+           (otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt "))")))))
+      (:jump-eq
+       (destructuring-bind (x y) args
+         (wt-nl "if (" `(coerce-loc :object ,x) "==" `(coerce-loc :object ,y) ") "))))
+    (wt-open-brace)
+    (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
+        (compute-unwind (label-denv exit) from)
+      (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
+      (wt-nl-go exit))
+    (wt-nl-close-brace)))
+
+(define-codegen (:cxx :escape) (instruction)
+  ;; All these boil down to calling ecl_unwind which unwinds stacks dynamically.
+  ;; If we want to implement call/cc, then this is the place where we dispatch.
+  #+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");")
+  (destructuring-bind (exit kind) (instruction-inputs instruction)
+    (ecase kind
+      (:go
+       ;; The second argument is passed as a value (index for jump).
+       (wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));"))
+      (:throw
+       ;; Unlike GO and RETURN-FROM, the destination is not known at compile time.
+       ;; TODO in some cases it is possible to prove the destination CATCH form.
+       (wt-nl "cl_throw(" exit ");"))
+      (:return-from
+       ;; The second argument is used only to signal the error.
+       (wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");")))))
+
+;;; JUMP is similar to GOTO, but it allows a fallthough.
+(define-codegen (:cxx :jump) (instruction)
+  (destructuring-bind (label from) (instruction-inputs instruction)
+    (unless (eq label (find-if #'labelp from))
+      (wt-nl-go label))))
+
+(define-codegen (:cxx :goto) (instruction)
+  (destructuring-bind (label) (instruction-inputs instruction)
+    (wt-nl-go label)))
+
+(define-codegen (:cxx :exit) (instruction)
+  (destructuring-bind (loc) (instruction-inputs instruction)
+    (wt-nl "return " loc ";")))