WIP: Label resolution support for JVM instructions.

7 files changed, 180 insertions, 74 deletions

diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux
index 68c651ba5..dff626c5c 100644
--- a/stdlib/source/lux/target/jvm/attribute/code.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code.lux
@@ -13,7 +13,7 @@
     [collection
      ["." row (#+ Row) ("#@." functor fold)]]]]
   ["." /// #_
-   [code
+   [program
     ["#." resources (#+ Resources)]]
    [encoding
     ["#." unsigned (#+ U2)]]]
diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
index 14dd13d6e..9c4c1ed38 100644
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
@@ -12,7 +12,7 @@
    ["//#" /// #_
     [constant (#+ Class)]
     ["#." index (#+ Index)]
-    [code
+    [program
      ["#." label (#+ Label)]]
     [encoding
      ["#." unsigned (#+ U2)]]]])
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
new file mode 100644
index 000000000..9d5dbe06c
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -0,0 +1,99 @@
+(.module:
+  [lux #*
+   [abstract
+    [monoid (#+ Monoid)]
+    [monad (#+ Monad do)]]
+   [control
+    ["." state (#+ State)]
+    ["." writer (#+ Writer)]
+    ["." function]]
+   [data
+    ["." error (#+ Error)]
+    [number
+     ["." nat]]
+    [collection
+     ["." dictionary (#+ Dictionary)]]]]
+  ["." / #_
+   ["#." instruction (#+ Instruction) ("#@." monoid)]
+   [//
+    [encoding
+     [unsigned (#+ U2)]]]])
+
+(type: #export Label Nat)
+
+(type: #export Jump U2)
+
+(type: #export Address Nat)
+
+(type: Resolver (Dictionary Label Address))
+
+(type: Tracker
+  {#program-counter Address
+   #next-label Label
+   #known-labels Resolver})
+
+(def: fresh
+  Tracker
+  {#program-counter 0
+   #next-label 0
+   #known-labels (dictionary.new nat.hash)})
+
+(type: #export Partial
+  (-> Resolver (Error Instruction)))
+
+(def: partial-identity
+  Partial
+  (function.constant (#error.Success /instruction.nop)))
+
+(structure: partial-monoid
+  (Monoid Partial)
+
+  (def: identity ..partial-identity)
+
+  (def: (compose left right)
+    (cond (is? ..partial-identity left)
+          right
+
+          (is? ..partial-identity right)
+          left
+
+          ## else
+          (function (_ resolver)
+            (do error.monad
+              [left (left resolver)
+               right (right resolver)]
+              (wrap (/instruction@compose left right)))))))
+
+(type: #export (Program a)
+  (State Tracker (Writer Partial a)))
+
+(def: #export new-label
+  (Program Label)
+  (function (_ tracker)
+    [(update@ #next-label inc tracker)
+     [..partial-identity
+      (get@ #next-label tracker)]]))
+
+(def: #export (set-label label)
+  (-> Label (Program Any))
+  (function (_ tracker)
+    [(update@ #known-labels
+              (dictionary.put label (get@ #program-counter tracker))
+              tracker)
+     [..partial-identity
+      []]]))
+
+(def: #export monad
+  ## TODO: Remove the coercion. It was added because the type-checker
+  ## seems to have a bug that is being triggered here.
+  (:coerce (Monad Program)
+           (writer.with ..partial-monoid
+                        (: (Monad (State Tracker))
+                           state.monad))))
+
+(def: #export (resolve program)
+  (All [a] (-> (Program a) (Error [Instruction a])))
+  (let [[tracker [partial output]] (state.run ..fresh program)]
+    (do error.monad
+      [instruction (partial (get@ #known-labels tracker))]
+      (wrap [instruction output]))))
diff --git a/stdlib/source/lux/target/jvm/code/condition.lux b/stdlib/source/lux/target/jvm/program/condition.lux
index 5769efc79..5769efc79 100644
--- a/stdlib/source/lux/target/jvm/code/condition.lux
+++ b/stdlib/source/lux/target/jvm/program/condition.lux
diff --git a/stdlib/source/lux/target/jvm/code.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index 480999e93..fcb2c1be7 100644
--- a/stdlib/source/lux/target/jvm/code.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux #*
+  [lux (#- Code)
    [abstract
     [monad (#+ do)]
     [monoid (#+ Monoid)]]
@@ -18,124 +18,129 @@
    [type
     abstract]]
   ["." // #_
-   ["#." index (#+ Index)]
-   ["#." descriptor (#+ Field Method)]
-   ["#." constant (#+ Class Reference)]
-   [encoding
-    ["#." unsigned (#+ U1 U2 U4)]]]
-  ["." / #_
    ["#." resources (#+ Resources)]
-   ["#" condition (#+ Environment Condition Local) ("#@." monoid)]
-   ["#." label (#+ Label Wide-Label)]])
+   ["/" condition (#+ Environment Condition Local) ("#@." monoid)]
+   ["#." label (#+ Label Wide-Label)]
+   ["/#" // #_
+    ["#." index (#+ Index)]
+    ["#." descriptor (#+ Field Method)]
+    ["#." constant (#+ Class Reference)]
+    [encoding
+     ["#." unsigned (#+ U1 U2 U4)]]]])
+
+(type: #export Size Nat)
 
 (type: #export Instruction
-  (-> [Environment Specification] (Error [Environment Specification])))
+  [Size (-> [Environment Specification] (Error [Environment Specification]))])
+
+(def: (instruction size condition transform)
+  (-> Size Condition (-> Specification Specification) Instruction)
+  [size
+   (function (_ [environment specification])
+     (do error.monad
+       [environment' (condition environment)]
+       (wrap [environment'
+              (transform specification)])))])
 
-(def: (instruction condition transform)
-  (-> Condition (-> Specification Specification) Instruction)
-  (function (_ [environment specification])
-    (do error.monad
-      [environment' (condition environment)]
-      (wrap [environment'
-             (transform specification)]))))
+(type: Code Nat)
 
 (def: (nullary' code)
-  (-> Nat Mutation)
+  (-> Code Mutation)
   (function (_ [offset binary])
     [(n/+ 1 offset)
      (error.assume
       (binary.write/8 offset code binary))]))
 
 (def: (nullary code [size mutation])
-  (-> Nat (-> Specification Specification))
+  (-> Code (-> Specification Specification))
   [(n/+ 1 size)
    (|>> mutation ((nullary' code)))])
 
 (def: (unary/1' code input0)
-  (-> Nat U1 Mutation)
+  (-> Code U1 Mutation)
   (function (_ [offset binary])
     [(n/+ 2 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)]
-        (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+        (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
 
 (def: (unary/1 code input0 [size mutation])
-  (-> Nat U1 (-> Specification Specification))
+  (-> Code U1 (-> Specification Specification))
   [(n/+ 2 size)
    (|>> mutation ((unary/1' code input0)))])
 
 (def: (unary/2' code input0)
-  (-> Nat U2 Mutation)
+  (-> Code U2 Mutation)
   (function (_ [offset binary])
     [(n/+ 3 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)]
-        (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+        (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
 
 (def: (unary/2 code input0 [size mutation])
-  (-> Nat U2 (-> Specification Specification))
+  (-> Code U2 (-> Specification Specification))
   [(n/+ 3 size)
    (|>> mutation ((unary/2' code input0)))])
 
 (def: (unary/4' code input0)
-  (-> Nat U4 Mutation)
+  (-> Code U4 Mutation)
   (function (_ [offset binary])
     [(n/+ 5 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)]
-        (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+        (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
 
 (def: (unary/4 code input0 [size mutation])
-  (-> Nat U4 (-> Specification Specification))
+  (-> Code U4 (-> Specification Specification))
   [(n/+ 5 size)
    (|>> mutation ((unary/4' code input0)))])
 
 (def: (binary/11' code input0 input1)
-  (-> Nat U1 U1 Mutation)
+  (-> Code U1 U1 Mutation)
   (function (_ [offset binary])
     [(n/+ 3 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)
-         _ (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)]
-        (binary.write/8 (n/+ 2 offset) (//unsigned.nat input1) binary)))]))
+         _ (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)]
+        (binary.write/8 (n/+ 2 offset) (///unsigned.nat input1) binary)))]))
 
 (def: (binary/11 code input0 input1 [size mutation])
-  (-> Nat U1 U1 (-> Specification Specification))
+  (-> Code U1 U1 (-> Specification Specification))
   [(n/+ 3 size)
    (|>> mutation ((binary/11' code input0 input1)))])
 
 (def: (binary/21' code input0 input1)
-  (-> Nat U2 U1 Mutation)
+  (-> Code U2 U1 Mutation)
   (function (_ [offset binary])
     [(n/+ 4 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)
-         _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)]
-        (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)))]))
+         _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)]
+        (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)))]))
 
 (def: (binary/21 code input0 input1 [size mutation])
-  (-> Nat U2 U1 (-> Specification Specification))
+  (-> Code U2 U1 (-> Specification Specification))
   [(n/+ 4 size)
    (|>> mutation ((binary/21' code input0 input1)))])
 
 (def: (trinary/211' code input0 input1 input2)
-  (-> Nat U2 U1 U1 Mutation)
+  (-> Code U2 U1 U1 Mutation)
   (function (_ [offset binary])
     [(n/+ 5 offset)
      (error.assume
       (do error.monad
         [_ (binary.write/8 offset code binary)
-         _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)
-         _ (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)]
-        (binary.write/8 (n/+ 4 offset) (//unsigned.nat input2) binary)))]))
+         _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)
+         _ (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)]
+        (binary.write/8 (n/+ 4 offset) (///unsigned.nat input2) binary)))]))
 
 (def: (trinary/211 code input0 input1 input2 [size mutation])
-  (-> Nat U2 U1 U1 (-> Specification Specification))
+  (-> Code U2 U1 U1 (-> Specification Specification))
   [(n/+ 5 size)
    (|>> mutation ((trinary/211' code input0 input1 input2)))])
 
@@ -149,7 +154,7 @@
     (|>> :representation))
 
   (template [<code> <name>]
-    [(def: #export <name> (|> <code> //unsigned.u1 :abstraction))]
+    [(def: #export <name> (|> <code> ///unsigned.u1 :abstraction))]
     
     [04 t-boolean]
     [05 t-char]
@@ -193,7 +198,7 @@
                                   ["18" dload 2]
                                   ["19" aload 1])
                   <simple-local-loads> (template [<code> <name> <output-size> <local-end>]
-                                         [[<code> <name> [] [] 0 <output-size> [[(//unsigned.u1 <local-end>)]]]]
+                                         [[<code> <name> [] [] 0 <output-size> [[(///unsigned.u1 <local-end>)]]]]
 
                                          ["1A" iload-0 1 0]
                                          ["1B" iload-1 1 1]
@@ -228,7 +233,7 @@
                                    ["39" dstore 2]
                                    ["3A" astore 1])
                   <simple-local-stores> (template [<code> <name> <input-size> <local-end>]
-                                          [[<code> <name> [] [] <input-size> 0 [[(//unsigned.u1 <local-end>)]]]]
+                                          [[<code> <name> [] [] <input-size> 0 [[(///unsigned.u1 <local-end>)]]]]
 
                                           ["3B" istore-0 1 0]
                                           ["3C" istore-1 1 1]
@@ -382,13 +387,13 @@
                             ["C6" ifnull 1 0]
                             ["C7" ifnonnull 1 0])
                   <fields> (template [<code> <name> <input-size> <output-size>]
-                             [[<code> <name> [[index (Index (Reference Field))]] [(//index.number index)] <input-size> <output-size> []]]
+                             [[<code> <name> [[index (Index (Reference Field))]] [(///index.number index)] <input-size> <output-size> []]]
 
                              ["B2" getstatic/1 0 1] ["B2" getstatic/2 0 2]
                              ["B3" putstatic/1 1 1] ["B3" putstatic/2 1 2]
                              ["B4" getfield/1  1 1] ["B4" getfield/2  1 2]
                              ["B5" putfield/1  2 1] ["B5" putfield/2  2 2])]
-  (template [<arity> <definitions>]
+  (template [<arity> <size> <definitions>]
     [(with-expansions [<definitions>' (template.splice <definitions>)]
        (template [<code> <name> <instruction-inputs> <arity-inputs> <consumes> <produces> <locals>]
          [(with-expansions [<inputs>' (template.splice <instruction-inputs>)
@@ -404,6 +409,7 @@
             (def: #export (<name> <input-names>)
               (-> <input-types> Instruction)
               (..instruction
+               <size>
                (`` ($_ /@compose
                        (/.consumes <consumes>)
                        (/.produces <produces>)
@@ -416,7 +422,7 @@
          <definitions>'
          ))]
 
-    [..nullary
+    [..nullary 1
      [["00" nop [] [] 0 0 []]
       <constants>
       ["57" pop [] [] 1 0 []]
@@ -444,7 +450,7 @@
       ["C2" monitorenter [] [] 1 0 []]
       ["C3" monitorexit [] [] 1 0 []]]]
 
-    [..unary/1
+    [..unary/1 2
      [["10" bipush  [[byte U1]] [byte] 0 1 []]
       ["12" ldc [[index U1]] [index] 0 1 []]
       <local-loads>
@@ -452,34 +458,34 @@
       ["A9" ret [[local Local]] [local] 0 0 [[local]]]
       ["BC" newarray [[type Primitive-Array-Type]] [(..code type)] 1 1 []]]]
 
-    [..unary/2
+    [..unary/2 3
      [["11" sipush  [[short U2]] [short] 0 1 []]
-      ["13" ldc-w/integer [[index (Index //constant.Integer)]] [(//index.number index)] 0 1 []]
-      ["13" ldc-w/float [[index (Index //constant.Float)]] [(//index.number index)] 0 1 []]
-      ["14" ldc2-w/long [[index (Index //constant.Long)]] [(//index.number index)] 0 1 []]
-      ["14" ldc2-w/double [[index (Index //constant.Double)]] [(//index.number index)] 0 1 []]
+      ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []]
+      ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []]
+      ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 1 []]
+      ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 1 []]
       <jumps>
       <fields>
-      ["BB" new [[index (Index Class)]] [(//index.number index)] 0 1 []]
-      ["BD" anewarray [[index (Index Class)]] [(//index.number index)] 1 1 []]
-      ["C0" checkcast [[index (Index Class)]] [(//index.number index)] 1 1 []]
-      ["C1" instanceof [[index (Index Class)]] [(//index.number index)] 1 1 []]
-      ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]
-      ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]
-      ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]]]
-
-    [..unary/4
+      ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []]
+      ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []]
+      ["C0" checkcast [[index (Index Class)]] [(///index.number index)] 1 1 []]
+      ["C1" instanceof [[index (Index Class)]] [(///index.number index)] 1 1 []]
+      ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]
+      ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]
+      ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
+
+    [..unary/4 5
      [["C8" goto-w [[label Wide-Label]] [label] 0 0 []]
       ["C9" jsr-w [[label Wide-Label]] [label] 0 1 []]]]
 
-    [..binary/11
+    [..binary/11 3
      [["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]]
 
-    [..binary/21
-     [["C5" multianewarray [[index (Index Class)] [count U1]] [(//index.number index) count] (//unsigned.nat count) 1 []]]]
+    [..binary/21 4
+     [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.number index) count] (///unsigned.nat count) 1 []]]]
 
-    [..trinary/211
-     [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index) count (//unsigned.u1 0)] (//unsigned.nat count) (//unsigned.nat output-count) []]]]
+    [..trinary/211 5
+     [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index) count (///unsigned.u1 0)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
     ))
 
 (structure: #export monoid
@@ -487,8 +493,9 @@
 
   (def: identity ..nop)
 
-  (def: (compose left right)
-    (function (_ input)
-      (do error.monad
-        [temp (left input)]
-        (right temp)))))
+  (def: (compose [left-size left] [right-size right])
+    [(n/+ left-size right-size)
+     (function (_ input)
+       (do error.monad
+         [temp (left input)]
+         (right temp)))]))
diff --git a/stdlib/source/lux/target/jvm/code/label.lux b/stdlib/source/lux/target/jvm/program/label.lux
index 7aaff5739..7aaff5739 100644
--- a/stdlib/source/lux/target/jvm/code/label.lux
+++ b/stdlib/source/lux/target/jvm/program/label.lux
diff --git a/stdlib/source/lux/target/jvm/code/resources.lux b/stdlib/source/lux/target/jvm/program/resources.lux
index fed6d4ce7..fed6d4ce7 100644
--- a/stdlib/source/lux/target/jvm/code/resources.lux
+++ b/stdlib/source/lux/target/jvm/program/resources.lux