From 78d4e5f923ff525805be9487c8ff9778fdd415f1 Mon Sep 17 00:00:00 2001
From: Daniel Kochmanski <daniel@turtleware.eu>
Date: Sat, 10 Feb 2018 16:46:38 +0100
Subject: [PATCH] Don't depend in blk-ref-{ccb,clb} which are broken anyway

We have dummy variable for that, so we refere to

(var-ref-ccb (blk-var blk))
(var-ref-clb (blk-var blk))

Brokeness comes from the fact that closures are computed after function
compilation pass-1 (and block is inside). Fixes #374.

Also improve comments in cmptypes to make it clear that these parts are not
used. Further refactor could make blk inherit from variable - then we wouldn't
have a dummy variable and unnecessary fields whatsoever.
---
 src/cmp/cmpblock.lsp | 35 +++++++++++++++--------------------
 src/cmp/cmptypes.lsp | 16 +++++-----------
 2 files changed, 20 insertions(+), 31 deletions(-)

diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp
index 37198bf57..35df81bd9 100644
--- a/src/cmp/cmpblock.lsp
+++ b/src/cmp/cmpblock.lsp
@@ -35,7 +35,7 @@
            (body (let ((*cmp-env* (cmp-env-copy)))
                    (cmp-env-register-block blk)
                    (c1progn (rest args)))))
-      (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
+      (when (or (var-ref-ccb blk-var) (var-ref-clb blk-var))
         (incf *setjmps*))
       (if (plusp (blk-ref blk))
           ;; FIXME! By simplifying the type of a BLOCK form so much (it is
@@ -53,12 +53,13 @@
   (if (plusp (var-ref (blk-var blk)))
       (let* ((blk-var (blk-var blk))
              (*env-lvl* *env-lvl*))
+        (check-vref blk-var)
         (wt-nl-open-brace)
-        (unless (or (blk-ref-ccb blk) (blk-ref-clb blk))
-          (setf (var-kind blk-var) :object
-                (var-loc blk-var) (next-lcl))
+        (when (eq :object (var-kind blk-var))
+          (setf (var-loc blk-var) (next-lcl))
           (wt-nl "cl_object " blk-var ";"))
-        (when (env-grows (blk-ref-ccb blk))
+        (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)
@@ -68,7 +69,7 @@
           (wt-nl "} else {")
           (c2expr body)
           (wt "}"))
-        (when (blk-ref-ccb blk) (decf *env*))
+        (when (var-ref-ccb blk-var) (decf *env*))
         (wt-nl-close-brace))
       (c2expr body)))
 
@@ -77,29 +78,23 @@
   (let ((name (first args)))
     (unless (symbolp name)
       (cmperr "The block name ~s is not a symbol." name))
-    ;; XXX: fixme here
     (multiple-value-bind (blk ccb clb unw)
         (cmp-env-search-block name)
       (unless blk
         (cmperr "The block ~s is undefined." name))
       (let* ((val (c1expr (second args)))
-             (var nil)
+             (var (blk-var blk))
              (type T))
-        (cond (ccb (setf (blk-ref-ccb blk) t
-                         type 'CCB
-                         var (blk-var blk)
-                         (var-kind var) 'CLOSURE
+        (cond (ccb (setf type 'CCB
                          (var-ref-ccb var) T))
-              (clb (setf (blk-ref-clb blk) t
-                         type 'CLB
-                         var (blk-var blk)))
-              (unw (setf type 'UNWIND-PROTECT
-                         var (blk-var blk))))
+              (clb (setf type 'CLB
+                         (var-ref-clb var) T))
+              (unw (setf type 'UNWIND-PROTECT)))
         (incf (blk-ref blk))
         (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val)))
-        (let ((output (make-c1form* 'RETURN-FROM :type 'T
-                                    :args blk type val var)))
-          (when var (add-to-read-nodes var output))
+        (let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val var)))
+          (when (or ccb clb unw)
+            (add-to-read-nodes var output))
           output)))))
 
 (defun c2return-from (c1form blk type val var)
diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp
index 4b0cd68d5..581068556 100644
--- a/src/cmp/cmptypes.lsp
+++ b/src/cmp/cmptypes.lsp
@@ -165,19 +165,13 @@
 
 (defstruct (blk (:include ref))
 ;  name                 ;;; Block name.
-;  (ref 0 :type fixnum) ;;; Number of references.
-;  ref-ccb              ;;; Cross closure reference.
-                        ;;; During Pass1, T or NIL.
-                        ;;; During Pass2, the ccb-lex for the
-                        ;;; block id, or NIL.
-;  ref-clb              ;;; Cross local function reference.
-                        ;;; During Pass1, T or NIL.
-                        ;;; During Pass2, the lex-address for the
-                        ;;; block id, or NIL.
-;  read-nodes           ;;; Nodes (c1forms) in which the reference occurs
+;  (ref 0 :type fixnum) ;;; Total number of block references.
+;  ref-ccb              ;;; Unused (see blk-var).
+;  ref-clb              ;;; Unused (see blk-var).
+;  read-nodes           ;;; Unused (see blk-var).
   exit                  ;;; Where to return.  A label.
   destination           ;;; Where the value of the block to go.
-  var                   ;;; Variable containing the block ID.
+  var                   ;;; Variable containing the block id and its references.
   (type '(VALUES &REST T)) ;;; Estimated type.
   )