Labels for all loop varieties

coalton.asd

@@ -32,6 +32,7 @@
                (:file "settings")
                (:file "utilities")
                (:file "global-lexical")
+               (:file "constants")
                (:module "algorithm"
                 :serial t
                 :components ((:file "tarjan-scc")

src/codegen/ast.lisp

@@ -56,15 +56,18 @@
    #:node-match-branches                ; ACCESSOR
    #:node-while                         ; STRUCT
    #:make-node-while                    ; CONSTRUCTOR
+   #:node-while-label                   ; ACCESSOR
    #:node-while-expr                    ; ACCESSOR
    #:node-while-body                    ; ACESSOR
    #:node-while-let                     ; STRUCT
    #:make-node-while-let                ; CONSTRUCTOR
+   #:node-while-let-label               ; ACESSOR
    #:node-while-let-pattern             ; ACCESSPR 
    #:node-while-let-expr                ; ACCESSOR
    #:node-while-let-body                ; ACESSOR
    #:node-for                           ; STRUCT
    #:make-node-for                      ; CONSTRUCTOR
+   #:node-for-label                     ; ACCESSOR
    #:node-for-pattern                   ; ACCESSPR 
    #:node-for-iter                      ; ACCESSOR
    #:node-for-body                      ; ACESSOR
@@ -191,36 +194,39 @@
 
 (defstruct (node-while (:include node))
   "A looping construct. Executes a body until an expression is false."
-  (expr (util:required 'expr) :type node :read-only t)
-  (body (util:required 'body) :type node :read-only t))
+  (label (util:required 'label) :type keyword :read-only t)
+  (expr  (util:required 'expr)  :type node    :read-only t)
+  (body  (util:required 'body)  :type node    :read-only t))
 
 (defstruct (node-while-let (:include node))
   "A looping construct. Executes a body until a pattern match fails."
-  (pattern  (util:required  'pattern)  :type  pattern  :read-only  t)
-  (expr     (util:required  'expr)     :type  node     :read-only  t)
-  (body     (util:required  'body)     :type  node     :read-only  t))
+  (label   (util:required 'label)   :type keyword :read-only t)
+  (pattern (util:required 'pattern) :type pattern :read-only t)
+  (expr    (util:required 'expr)    :type node    :read-only t)
+  (body    (util:required 'body)    :type node    :read-only t))
 
 (defstruct (node-for (:include node))
   "A looping construct. Consumes an iterator, matching a pattern against
 its elements, and executes body in the context of any variables bond
 in the match."
-  (pattern  (util:required  'pattern)  :type  pattern  :read-only  t)
-  (iter     (util:required  'iter)     :type  node     :read-only  t)
-  (body     (util:required  'body)     :type  node     :read-only  t))
+  (label   (util:required 'label)   :type keyword :read-only t)
+  (pattern (util:required 'pattern) :type pattern :read-only t)
+  (iter    (util:required 'iter)    :type node    :read-only t)
+  (body    (util:required 'body)    :type node    :read-only t))
 
 (defstruct (node-loop (:include node))
   "A labelled looping construct. Loops forever until broken out of by a
 call to (break)."
-  (label (util:required 'label) :type (or keyword null) :read-only t)
-  (body  (util:required 'body)  :type node              :read-only t))
+  (label (util:required 'label) :type keyword :read-only t)
+  (body  (util:required 'body)  :type node    :read-only t))
 
 (defstruct (node-break (:include node))
   "A break statment used to exit a loop."
-  (label (util:required 'label) :type (or null keyword) :read-only t))
+  (label (util:required 'label) :type keyword :read-only t))
 
 (defstruct (node-continue (:include node))
   "A continue statment used to skip to the next iteration of a loop."
-  (label (util:required 'label) :type (or null keyword) :read-only t))
+  (label (util:required 'label) :type keyword :read-only t))
 
 (defstruct (node-seq (:include node))
   "A series of statements to be executed sequentially"

src/codegen/codegen-expression.lisp

@@ -13,15 +13,19 @@
    (#:settings #:coalton-impl/settings)
    (#:util #:coalton-impl/util)
    (#:rt #:coalton-impl/runtime)
-   (#:tc #:coalton-impl/typechecker))
+   (#:tc #:coalton-impl/typechecker)
+   (#:const #:coalton-impl/constants))
   (:export
    #:codegen-expression                 ; FUNCTION
    ))
 
 (in-package #:coalton-impl/codegen/codegen-expression)
 
-(defconstant +break-label+ '%break)
-(defconstant +continue-label+ '%continue)
+(defun continue-label (label)
+  (alexandria:make-keyword (format nil "~a-CONTINUE" label)))
+
+(defun break-label (label)
+  (alexandria:make-keyword (format nil "~a-BREAK" label)))
 
 (defgeneric codegen-expression (node current-function env)
   (:method ((node node-literal) current-function env)
@@ -115,86 +119,124 @@
              (type (or null symbol) current-function))
 
     (let ((pred-expr (codegen-expression (node-while-expr expr) current-function env))
-          (body-expr (codegen-expression (node-while-body expr) current-function env)))
-      `(loop
-         :named ,+break-label+ 
-         :while ,pred-expr
-         :do (block ,+continue-label+ ,body-expr))))
+          (body-expr (codegen-expression (node-while-body expr) current-function env))
+          (label (node-while-label expr)))
+      (if (eq label const:+default-loop-label+)
+          `(loop
+             :named ,(break-label label)
+             :while ,pred-expr
+             :do
+                (block ,(continue-label label) ,body-expr))
+          `(block ,(break-label const:+default-loop-label+)
+             (loop
+               :named ,(break-label label)
+               :while ,pred-expr
+               :do
+                  (block ,(continue-label const:+default-loop-label+) 
+                    (block ,(continue-label label) ,body-expr)))))))
 
   (:method ((expr node-while-let) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
 
     (let ((match-expr (codegen-expression (node-while-let-expr expr) current-function env))
           (body-expr (codegen-expression (node-while-let-body expr) current-function env))
+          (label (node-while-let-label expr))
           (match-var (gensym "MATCH")))
 
       (multiple-value-bind (pred bindings)
           (codegen-pattern (node-while-let-pattern expr) match-var env)
-        `(loop
-           :named ,+break-label+
-           :for ,match-var := ,(if settings:*emit-type-annotations*
-                                   `(the ,(tc:lisp-type (node-type (node-while-let-expr expr)) env) ,match-expr)
-                                   match-expr)
-           :while ,pred
-           :do (block ,+continue-label+
-                 ,(cond ((null bindings) body-expr)
-                        (t `(let ,bindings
-                              (declare (ignorable ,@(mapcar #'car bindings)))
-                              ,body-expr))))))))
-
+        (if (eq label const:+default-loop-label+)
+            `(loop
+               :named ,(break-label label)
+               :for ,match-var := ,(if settings:*emit-type-annotations*
+                                       `(the ,(tc:lisp-type (node-type (node-while-let-expr expr)) env) ,match-expr)
+                                       match-expr)
+               :while ,pred
+               :do (block ,(continue-label label)
+                     ,(cond ((null bindings) body-expr)
+                            (t `(let ,bindings
+                                  (declare (ignorable ,@(mapcar #'car bindings)))
+                                  ,body-expr)))))
+
+            `(block ,(break-label const:+default-loop-label+)
+               (loop
+                 :named ,(break-label label)
+                 :for ,match-var := ,(if settings:*emit-type-annotations*
+                                         `(the ,(tc:lisp-type (node-type (node-while-let-expr expr)) env) ,match-expr)
+                                         match-expr)
+                 :while ,pred
+                 :do
+                    (block ,(continue-label const:+default-loop-label+)
+                      (block ,(continue-label label)
+                        ,(cond ((null bindings) body-expr)
+                               (t `(let ,bindings
+                                     (declare (ignorable ,@(mapcar #'car bindings)))
+                                     ,body-expr)))))))))))
 
   (:method ((expr node-for) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
 
     (let ((body-expr (codegen-expression (node-for-body expr) current-function env))
           (iter-expr (codegen-expression (node-for-iter expr) current-function env))
+          (label (node-for-label expr))
           (iter-var (gensym "ITERATOR"))
           (match-var (gensym "MATCH"))
           (next! (util:find-symbol "NEXT!" (find-package "COALTON-LIBRARY/ITERATOR"))))
 
       (multiple-value-bind (pred bindings)
           (codegen-pattern (node-for-pattern expr) match-var env)
-
-        `(loop
-           :named ,+break-label+
-           :with ,iter-var := ,iter-expr
-           :for ,match-var := (,next! ,iter-var)
-           :while ,pred
-           :do (block ,+continue-label+
-                 ,(cond ((null bindings) body-expr)
-                        (t `(let ,bindings
-                              (declare (ignorable ,@(mapcar #'car bindings)))
-                              ,body-expr))))))))
+        (if (eq label const:+default-loop-label+) 
+            `(loop
+               :named ,(break-label label)
+               :with ,iter-var := ,iter-expr
+               :for ,match-var := (,next! ,iter-var)
+               :while ,pred
+               :do (block ,(continue-label label)
+                     ,(cond ((null bindings) body-expr)
+                            (t `(let ,bindings
+                                  (declare (ignorable ,@(mapcar #'car bindings)))
+                                  ,body-expr)))))
+
+            `(block ,(break-label const:+default-loop-label+)
+               (loop
+                 :named ,(break-label label)
+                 :with ,iter-var := ,iter-expr
+                 :for ,match-var := (,next! ,iter-var)
+                 :while ,pred
+                 :do (block ,(continue-label const:+default-loop-label+)
+                       (block ,(continue-label label)
+                         ,(cond ((null bindings) body-expr)
+                                (t `(let ,bindings
+                                      (declare (ignorable ,@(mapcar #'car bindings)))
+                                      ,body-expr)))))))))))
 
   (:method ((expr node-loop) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
     (let ((body-expr (codegen-expression (node-loop-body expr) current-function env))
           (label (node-loop-label expr)))
-      `(block ,+break-label+
-         (loop ,@(when label (list :named label))
-               :do ,(if label
-                        `(tagbody ,label
-                            (block ,+continue-label+
-                              ,body-expr))
-                        `(block ,+continue-label+
-                           ,body-expr))))))
+      (if (eq label const:+default-loop-label+) 
+          `(loop ,(break-label label)
+                 :do (block ,(continue-label label)
+                       ,body-expr))
+
+          `(block ,(break-label const:+default-loop-label+)
+             (loop ,(break-label label)
+                   :do (block ,(continue-label const:+default-loop-label+)
+                         (block ,(continue-label label)
+                           ,body-expr)))))))
 
   (:method ((expr node-break) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
-    (if (node-break-label expr)
-        `(return-from ,(node-break-label expr))
-        `(return-from ,+break-label+)))
+    `(return-from ,(break-label (node-break-label expr))))
 
   (:method ((expr node-continue) current-function env)
     (declare (type tc:environment env)
              (type (or null symbol) current-function))
-    (if (node-continue-label expr)
-        `(go ,(node-continue-label expr))
-        `(return-from ,+continue-label+)))
+    `(return-from ,(continue-label (node-continue-label expr))))
 
   (:method ((expr node-match) current-function env)
     (declare (type tc:environment env)

src/codegen/transformations.lisp

@@ -124,6 +124,7 @@
     (let ((node
             (make-node-while
              :type (node-type node)
+             :label (node-while-label node)
              :expr (traverse (node-while-expr node) funs bound-variables)
              :body (traverse (node-while-body node) funs bound-variables))))
       (call-if node :while funs bound-variables)))
@@ -133,6 +134,7 @@
     (let ((node
             (make-node-while-let
              :type tc:*unit-type*
+             :label (node-while-let-label node)
              :pattern (node-while-let-pattern node)
              :expr (traverse (node-while-let-expr node) funs bound-variables)
              :body (traverse (node-while-let-body node) funs bound-variables))))
@@ -143,6 +145,7 @@
     (let ((node
             (make-node-for
              :type tc:*unit-type*
+             :label (node-for-label node)
              :pattern (node-for-pattern node)
              :iter (traverse (node-for-iter node) funs bound-variables)
              :body (traverse (node-for-body node) funs bound-variables))))

src/codegen/translate-expression.lisp

@@ -558,6 +558,7 @@ Returns a `node'.")
 
     (make-node-while 
      :type tc:*unit-type*
+     :label (tc:node-while-label expr)
      :expr (translate-expression (tc:node-while-expr expr) ctx env)
      :body (translate-expression (tc:node-while-body expr) ctx env)))
 
@@ -568,6 +569,7 @@ Returns a `node'.")
     (make-node-while-let
      :type tc:*unit-type*
      :pattern (translate-pattern (tc:node-while-let-pattern expr))
+     :label (tc:node-while-let-label expr)
      :expr (translate-expression (tc:node-while-let-expr expr) ctx env)
      :body (translate-expression (tc:node-while-let-body expr) ctx env)))
 
@@ -652,6 +654,7 @@ Returns a `node'.")
 
       (make-node-for
        :type tc:*unit-type*
+       :label (tc:node-for-label expr)
        :pattern some-pattern
        :iter into-iter-node
        :body (translate-expression (tc:node-for-body expr) ctx env))))

src/constants.lisp

@@ -0,0 +1,15 @@
+;;;; constants.lisp
+;;;;
+;;;; This file contains constant values used throughout compilation.
+
+(defpackage #:coalton-impl/constants
+  (:use #:cl)
+  (:export
+   #:+default-loop-label+               ; VARIABLE
+   ))
+
+(in-package #:coalton-impl/constants)
+
+(defparameter +default-loop-label+ :coalton-loop
+  "Supplied as a loop label for while, while-let, for, loop, break, and
+continue when a label is not supplied by the user.")