Add 'lisp-toplevel' form to coalton syntax

lisp-toplevel may appear at any point in a coalton-toplevel or coalton
file context.

During code generation, lisp forms are merged with coalton definitions
according to the rule:

1. coalton forms are emitted in scc order
2. every time a coalton form is emitted, all lisp forms lexically preceding that form are emitted first

Convert math/num.lisp from interleaved lisp and coalton-toplevel forms
to a single coalton-toplevel form containing multiple lisp-toplevel forms.

Author: jbouwman

Diff for: library/math/num.lisp

@@ -22,6 +22,7 @@
    #:optimize-bindings)
   (:local-nicknames
    (#:util #:coalton-impl/util)
+   (#:parser #:coalton-impl/parser)
    (#:settings #:coalton-impl/settings)
    (#:global-lexical #:coalton-impl/global-lexical)
    (#:rt #:coalton-impl/runtime)
@@ -41,41 +42,104 @@ A function bound here will be called with a keyword category, and one or more ad
 
     Toplevel definitions, after type checking and before compilation.")
 
+;; The following functions control the output order of compiled
+;; definitions and interleaved lisp expressions.
+;;
+;; Toplevel define and instance forms are compiled to 1 or more named,
+;; lisp-source-valued output definitions: when these definitions are
+;; generated, they are associated with the starting source offset of their
+;; toplevel form:
+;;
+;;   toplevel definition:
+;;     #<def .... (300 . 345)>
+;;
+;;   bindings (lisp definitions):
+;;     (300 b1 .. bn)
+;;
+;; Then when compile-definitions emits the full set of output
+;; definitions, any lisp source forms that occurred earlier in the
+;; file are emitted first.
+
+(defun bindings-offset (bindings offsets)
+  "Given a list of binding names, and a name -> offset map, return the earliest binding start offset."
+  (apply #'min
+         (mapcar (lambda (binding)
+                   (or (gethash (car binding) offsets) 0))
+                 bindings)))
+
+(defun merge-forms (forms-a forms-b &optional merged)
+  "Stably merge two lists of forms.
+
+1. The inputs and output are lists of 2-lists, structured as (OFFSET FORM).
+2. The order of both lists is preserved.
+3. Lists are merged by recursively selecting the head of the list with the lowest offset."
+  (cond ((endp forms-a)
+         (return-from merge-forms
+           (append (nreverse merged) forms-b)))
+        ((endp forms-b)
+         (return-from merge-forms
+           (append (nreverse merged) forms-a)))
+        ((< (caar forms-a)
+            (caar forms-b))
+         (push (pop forms-a) merged))
+        (t
+         (push (pop forms-b) merged)))
+  (merge-forms forms-a forms-b merged))
+
+(defun compile-definitions (sccs definitions lisp-forms offsets env)
+  "Compile SCCs and generate a final output definition list, merging any present lisp sources."
+  (let ((bindings (loop :for scc :in sccs
+                        :for bindings := (remove-if-not (lambda (binding)
+                                                          (find (car binding) scc))
+                                                        definitions)
+                        :collect (cons (bindings-offset bindings offsets)
+                                       (compile-scc bindings env))))
+        (lisp-forms (mapcar (lambda (lisp-form)
+                              (cons (car (parser:toplevel-lisp-form-source lisp-form))
+                                    (parser:toplevel-lisp-form-body lisp-form)))
+                            lisp-forms)))
+    (mapcan #'cdr (merge-forms bindings lisp-forms))))
+
+(defun definition-bindings (definitions env offsets)
+  (loop :for define :in definitions
+        :for offset := (car (tc:toplevel-define-source define))
+        :for name := (tc:node-variable-name (tc:toplevel-define-name define))
+        :for compiled-node := (translate-toplevel define env)
+
+        :when *codegen-hook*
+          :do (funcall *codegen-hook* :ast
+                       name
+                       (tc:lookup-value-type env name)
+                       (tc:binding-value define))
+
+        :collect (cons name compiled-node)))
+
+(defun instance-bindings (instances env offsets)
+  (loop :for instance :in instances
+        :for offset := (car (tc:toplevel-define-instance-source instance))
+        :for instance-bindings := (translate-instance instance env)
+
+        :do (dolist (binding instance-bindings)
+              (setf (gethash (car binding) offsets) offset))
+        :append instance-bindings))
+
 (defun compile-translation-unit (translation-unit monomorphize-table env)
   (declare (type tc:translation-unit translation-unit)
            (type hash-table monomorphize-table)
            (type tc:environment env))
 
-  (let* ((definitions
+  (let* ((offsets (make-hash-table))
+         (definitions
            (append
-            (loop :for define :in (tc:translation-unit-definitions translation-unit)
-                  :for name := (tc:node-variable-name (tc:toplevel-define-name define))
-
-                  :for compiled-node := (translate-toplevel define env)
-
-                  :do (when *codegen-hook*
-                        (funcall *codegen-hook*
-                                 ':AST
-                                 name
-                                 (tc:lookup-value-type env name)
-                                 (tc:binding-value define)))
-                  :collect (cons name compiled-node))
-
-            ;; HACK: this load bearing reverse should be replaced with an actual solution
-            (loop :for instance :in (reverse (tc:translation-unit-instances translation-unit))
-                  :append (translate-instance instance env))))
-
-         (definition-names
-           (mapcar #'car definitions)))
+            (definition-bindings (tc:translation-unit-definitions translation-unit) env offsets)
+            (instance-bindings (tc:translation-unit-instances translation-unit) env offsets)))
+         (definition-names (mapcar #'car definitions)))
 
     (multiple-value-bind (definitions env)
-        (optimize-bindings
-         definitions
-         monomorphize-table
-         *package*
-         env)
+        (optimize-bindings definitions monomorphize-table *package* env)
 
-      (let ((sccs (node-binding-sccs definitions)))
+      (let ((sccs (node-binding-sccs definitions))
+            (lisp-forms (tc:translation-unit-lisp-forms translation-unit)))
 
         (values
          `(progn
@@ -102,13 +166,7 @@ A function bound here will be called with a keyword category, and one or more ad
                 (list
                  `(declaim (sb-ext:start-block ,@definition-names))))
 
-            ,@(loop :for scc :in sccs
-                    :for bindings
-                      := (remove-if-not
-                          (lambda (binding)
-                            (find (car binding) scc))
-                          definitions)
-                    :append (compile-scc bindings env))
+            ,@(compile-definitions sccs definitions lisp-forms offsets env)
 
             #+sbcl
             ,@(when (eq sb-ext:*block-compile-default* :specified)

Diff for: src/codegen/program.lisp

@@ -43,53 +43,56 @@
                                  file
                                  env)
 
-      (multiple-value-bind (class-definitions env)
-          (tc:toplevel-define-class (parser:program-classes program)
-                                    file
-                                    env)
+      (let ((all-instances (append instances (parser:program-instances program))))
+
+        (multiple-value-bind (class-definitions env)
+            (tc:toplevel-define-class (parser:program-classes program)
+                                      file
+                                      env)
 
-        (multiple-value-bind (ty-instances env)
-            (tc:toplevel-define-instance (append instances (parser:program-instances program)) env file)
+          (multiple-value-bind (ty-instances env)
+              (tc:toplevel-define-instance all-instances env file)
 
-          (multiple-value-bind (toplevel-definitions env)
-              (tc:toplevel-define (parser:program-defines program)
-                                  (parser:program-declares program)
-                                  file
-                                  env)
+            (multiple-value-bind (toplevel-definitions env)
+                (tc:toplevel-define (parser:program-defines program)
+                                    (parser:program-declares program)
+                                    file
+                                    env)
 
-            (multiple-value-bind (toplevel-instances)
-                (tc:toplevel-typecheck-instance ty-instances
-                                                (append instances (parser:program-instances program))
-                                                env
-                                                file)
+              (multiple-value-bind (toplevel-instances)
+                  (tc:toplevel-typecheck-instance ty-instances
+                                                  all-instances
+                                                  env
+                                                  file)
 
-              (setf env (tc:toplevel-specialize (parser:program-specializations program) env file))
+                (setf env (tc:toplevel-specialize (parser:program-specializations program) env file))
 
-              (let ((monomorphize-table (make-hash-table :test #'eq))
+                (let ((monomorphize-table (make-hash-table :test #'eq))
 
-                    (translation-unit
-                      (tc:make-translation-unit
-                       :types type-definitions
-                       :definitions toplevel-definitions
-                       :classes class-definitions
-                       :instances toplevel-instances
-                       :package *package*)))
+                      (translation-unit
+                        (tc:make-translation-unit
+                         :types type-definitions
+                         :definitions toplevel-definitions
+                         :classes class-definitions
+                         :instances toplevel-instances
+                         :lisp-forms (parser:program-lisp-forms program)
+                         :package *package*)))
 
-                (loop :for define :in (parser:program-defines program)
-                      :when (parser:toplevel-define-monomorphize define)
-                        :do (setf (gethash (parser:node-variable-name (parser:toplevel-define-name define))
-                                           monomorphize-table)
-                                  t))
+                  (loop :for define :in (parser:program-defines program)
+                        :when (parser:toplevel-define-monomorphize define)
+                          :do (setf (gethash (parser:node-variable-name (parser:toplevel-define-name define))
+                                             monomorphize-table)
+                                    t))
 
-                (loop :for declare :in (parser:program-declares program)
-                      :when (parser:toplevel-declare-monomorphize declare)
-                        :do (setf (gethash (parser:identifier-src-name (parser:toplevel-declare-name declare))
-                                           monomorphize-table)
-                                  t))
+                  (loop :for declare :in (parser:program-declares program)
+                        :when (parser:toplevel-declare-monomorphize declare)
+                          :do (setf (gethash (parser:identifier-src-name (parser:toplevel-declare-name declare))
+                                             monomorphize-table)
+                                    t))
 
-                (analysis:analyze-translation-unit translation-unit env file)
+                  (analysis:analyze-translation-unit translation-unit env file)
 
-                (codegen:compile-translation-unit translation-unit monomorphize-table env)))))))))
+                  (codegen:compile-translation-unit translation-unit monomorphize-table env))))))))))
 
 
 (defun expression-entry-point (node file)

Diff for: src/entry.lisp

@@ -45,6 +45,9 @@
 (define-coalton-editor-macro coalton:define-instance (instance &body method-definitions)
   "Define an instance of a type class. (Coalton top-level operator.)")
 
+(define-coalton-editor-macro coalton:lisp-toplevel (name from-ty to-ty)
+  "Include lisp forms. (Coalton top-level operator.)")
+
 (define-coalton-editor-macro coalton:specialize (name from-ty to-ty)
   "Declare a specialization for a function. (Coalton top-level operator.)")
 

Diff for: src/faux-macros.lisp

@@ -27,6 +27,7 @@
    #:define-class
    #:define-instance
    #:repr
+   #:lisp-toplevel
    #:monomorphize
    #:specialize
    #:unable-to-codegen)

Diff for: src/package.lisp

@@ -521,6 +521,7 @@
       :defines (rename-variables-generic% (program-defines program) ctx)
       :classes (program-classes program) ; Class type variables are renamed during kind inference
       :instances (rename-variables-generic% (program-instances program) ctx)
+      :lisp-forms (program-lisp-forms program)
       :specializations (program-specializations program) ; Renaming type variables in specializations is not valid
       )
      ctx))