Constant pool support, finished label machinery, and enhanced machinery for writing bytecode instructions.

6 files changed, 421 insertions, 54 deletions

diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
index 9c4c1ed38..19de9c789 100644
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
@@ -13,22 +13,22 @@
     [constant (#+ Class)]
     ["#." index (#+ Index)]
     [program
-     ["#." label (#+ Label)]]
+     ["#." jump (#+ Jump)]]
     [encoding
      ["#." unsigned (#+ U2)]]]])
 
 (type: #export Exception
-  {#start-pc Label
-   #end-pc Label
-   #handler-pc Label
+  {#start-pc Jump
+   #end-pc Jump
+   #handler-pc Jump
    #catch-type (Index Class)})
 
 (def: #export equivalence
   (Equivalence Exception)
   ($_ equivalence.product
-      ////label.equivalence
-      ////label.equivalence
-      ////label.equivalence
+      ////jump.equivalence
+      ////jump.equivalence
+      ////jump.equivalence
       ////index.equivalence
       ))
 
@@ -49,17 +49,17 @@
 (def: #export parser
   (Parser Exception)
   ($_ <>.and
-      ////label.parser
-      ////label.parser
-      ////label.parser
+      ////jump.parser
+      ////jump.parser
+      ////jump.parser
       ////index.parser
       ))
 
 (def: #export writer
   (Writer Exception)
   ($_ binaryF.and
-      ////label.writer
-      ////label.writer
-      ////label.writer
+      ////jump.writer
+      ////jump.writer
+      ////jump.writer
       ////index.writer
       ))
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
index 149a893bb..c9e136380 100644
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ b/stdlib/source/lux/target/jvm/constant/pool.lux
@@ -10,7 +10,10 @@
      ["<2>" binary (#+ Parser)]]]
    [data
     ["." error (#+ Error)]
-    ["." text ("#;." equivalence)
+    [number
+     ["." int]
+     ["." frac]]
+    ["." text
      ["%" format]]
     [format
      [".F" binary (#+ Writer)]]
@@ -18,8 +21,10 @@
      ["." list ("#;." fold)]
      ["." row (#+ Row)]]]
    [type
-    abstract]]
-  ["." // (#+ UTF8 Class Constant) ("#;." class-equivalence)
+    abstract]
+   [macro
+    ["." template]]]
+  ["." // (#+ UTF8 Class Long Double Constant)
    [//
     [encoding
      ["." unsigned]]
@@ -43,7 +48,7 @@
           (#.Some entry)
           (case entry
             (<tag> reference)
-            (if (<=> reference <value>)
+            (if (:: <=> = reference <value>)
               [pool
                <index>]
               <try-again>)
@@ -99,7 +104,7 @@
           (#.Some entry)
           (case entry
             (<tag> actual)
-            (if (<=> actual <expected>)
+            (if (:: <=> = actual <expected>)
               [pool
                (#error.Success <index>)]
               <try-again>)
@@ -120,21 +125,27 @@
 (type: (Finder of)
   (-> of (State Pool (Error (Index of)))))
 
-(def: #export (utf8 value)
-  (Adder UTF8)
-  (!add #//.UTF8 text;= value))
+(template [<name> <type> <tag> <equivalence> <format>]
+  [(def: #export (<name> value)
+     (Adder <type>)
+     (!add <tag> <equivalence> value))
 
-(def: #export (fetch-utf8 index)
-  (Fetcher UTF8)
-  (!fetch #//.UTF8 index))
+   (`` (def: #export ((~~ (template.identifier ["fetch-" <name>])) index)
+         (Fetcher <type>)
+         (!fetch <tag> index)))
 
-(def: #export (find-utf8 reference)
-  (Finder UTF8)
-  (!find #//.UTF8 text;= %.text reference))
+   (`` (def: #export ((~~ (template.identifier ["find-" <name>])) reference)
+         (Finder <type>)
+         (!find <tag> <equivalence> <format> reference)))]
+
+  [long Long #//.Long (//.value-equivalence int.equivalence) (|>> //.value %.int)]
+  [double Double #//.Double (//.value-equivalence frac.equivalence) (|>> //.value %.frac)]
+  [utf8 UTF8 #//.UTF8 text.equivalence %.text]
+  )
 
 (def: (class' value)
   (Adder Class)
-  (!add #//.Class //;= value))
+  (!add #//.Class //.class-equivalence value))
 
 (def: #export (class name)
   (-> UTF8 (State Pool (Index Class)))
@@ -147,7 +158,7 @@
     (-> (Descriptor kind)
         (State Pool (Index (Descriptor kind)))))
   (let [value (descriptor.descriptor value)]
-    (!add #//.UTF8 text;= value)))
+    (!add #//.UTF8 text.equivalence value)))
 
 (def: #export parser
   (Parser Pool)
diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
index 86495f38e..892d2f86d 100644
--- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux
+++ b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
@@ -1,7 +1,8 @@
 (.module:
   [lux (#- nat)
    [abstract
-    [equivalence (#+ Equivalence)]]
+    [equivalence (#+ Equivalence)]
+    [order (#+ Order)]]
    [control
     ["<>" parser ("#@." functor)
      ["<2>" binary (#+ Parser)]]]
@@ -28,6 +29,13 @@
     (def: (= reference sample)
       (n/= (:representation reference) (:representation sample))))
 
+  (structure: #export order
+    (All [brand] (Order (Unsigned brand)))
+    
+    (def: &equivalence ..equivalence)
+    (def: (< reference sample)
+      (n/< (:representation reference) (:representation sample))))
+
   (template [<bytes> <name> <size> <constructor> <max> <+>]
     [(with-expansions [<raw> (template.identifier [<name> "'"])]
        (abstract: #export <raw> {} Any)
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
index 9d5dbe06c..673743c73 100644
--- a/stdlib/source/lux/target/jvm/program.lux
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -6,23 +6,29 @@
    [control
     ["." state (#+ State)]
     ["." writer (#+ Writer)]
-    ["." function]]
+    ["." function]
+    ["." exception (#+ exception:)]]
    [data
     ["." error (#+ Error)]
+    [text
+     ["%" format]]
     [number
      ["." nat]]
     [collection
      ["." dictionary (#+ Dictionary)]]]]
   ["." / #_
-   ["#." instruction (#+ Instruction) ("#@." monoid)]
-   [//
+   ["#." condition (#+ Local)]
+   ["#." jump (#+ Jump Big-Jump)]
+   ["#." instruction (#+ Primitive-Array-Type Instruction) ("#@." monoid)]
+   ["/#" // #_
+    ["#." index]
     [encoding
-     [unsigned (#+ U2)]]]])
+     ["#." unsigned (#+ U1 U2)]]
+    ["#." constant (#+ UTF8)
+     ["#/."pool (#+ Pool)]]]])
 
 (type: #export Label Nat)
 
-(type: #export Jump U2)
-
 (type: #export Address Nat)
 
 (type: Resolver (Dictionary Label Address))
@@ -65,21 +71,23 @@
               (wrap (/instruction@compose left right)))))))
 
 (type: #export (Program a)
-  (State Tracker (Writer Partial a)))
+  (State [Pool Tracker] (Writer Partial a)))
 
 (def: #export new-label
   (Program Label)
-  (function (_ tracker)
-    [(update@ #next-label inc tracker)
+  (function (_ [pool tracker])
+    [[pool
+      (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)
+  (function (_ [pool tracker])
+    [[pool
+      (update@ #known-labels
+               (dictionary.put label (get@ #program-counter tracker))
+               tracker)]
      [..partial-identity
       []]]))
 
@@ -88,12 +96,352 @@
   ## seems to have a bug that is being triggered here.
   (:coerce (Monad Program)
            (writer.with ..partial-monoid
-                        (: (Monad (State Tracker))
+                        (: (Monad (State [Pool Tracker]))
                            state.monad))))
 
-(def: #export (resolve program)
-  (All [a] (-> (Program a) (Error [Instruction a])))
-  (let [[tracker [partial output]] (state.run ..fresh program)]
+(def: #export (resolve pool program)
+  (All [a] (-> Pool (Program a) (Error [Pool Instruction a])))
+  (let [[[pool tracker] [partial output]] (state.run [pool ..fresh] program)]
     (do error.monad
       [instruction (partial (get@ #known-labels tracker))]
-      (wrap [instruction output]))))
+      (wrap [pool instruction output]))))
+
+(def: (nullary instruction)
+  (-> Instruction (Program Any))
+  (function (_ [pool tracker])
+    [[pool tracker]
+     [(function.constant (#error.Success instruction))
+      []]]))
+
+(template [<name> <instruction>]
+  [(def: #export <name> (nullary <instruction>))]
+
+  [nop /instruction.nop]
+  [aconst-null /instruction.aconst-null]
+
+  [iconst-m1 /instruction.iconst-m1]
+  [iconst-0 /instruction.iconst-0]
+  [iconst-1 /instruction.iconst-1]
+  [iconst-2 /instruction.iconst-2]
+  [iconst-3 /instruction.iconst-3]
+  [iconst-4 /instruction.iconst-4]
+  [iconst-5 /instruction.iconst-5]
+
+  [lconst-0 /instruction.lconst-0]
+  [lconst-1 /instruction.lconst-1]
+
+  [fconst-0 /instruction.fconst-0]
+  [fconst-1 /instruction.fconst-1]
+  [fconst-2 /instruction.fconst-2]
+  
+  [dconst-0 /instruction.dconst-0]
+  [dconst-1 /instruction.dconst-1]
+
+  [pop /instruction.pop]
+  [pop2 /instruction.pop2]
+  
+  [dup /instruction.dup]
+  [dup-x1 /instruction.dup-x1]
+  [dup-x2 /instruction.dup-x2]
+  [dup2 /instruction.dup2]
+  [dup2-x1 /instruction.dup2-x1]
+  [dup2-x2 /instruction.dup2-x2]
+  
+  [swap /instruction.swap]
+
+  [istore-0 /instruction.istore-0]
+  [istore-1 /instruction.istore-1]
+  [istore-2 /instruction.istore-2]
+  [istore-3 /instruction.istore-3]
+
+  [lstore-0 /instruction.lstore-0]
+  [lstore-1 /instruction.lstore-1]
+  [lstore-2 /instruction.lstore-2]
+  [lstore-3 /instruction.lstore-3]
+
+  [fstore-0 /instruction.fstore-0]
+  [fstore-1 /instruction.fstore-1]
+  [fstore-2 /instruction.fstore-2]
+  [fstore-3 /instruction.fstore-3]
+
+  [dstore-0 /instruction.dstore-0]
+  [dstore-1 /instruction.dstore-1]
+  [dstore-2 /instruction.dstore-2]
+  [dstore-3 /instruction.dstore-3]
+  
+  [astore-0 /instruction.astore-0]
+  [astore-1 /instruction.astore-1]
+  [astore-2 /instruction.astore-2]
+  [astore-3 /instruction.astore-3]
+
+  [iaload /instruction.iaload]
+  [laload /instruction.laload]
+  [faload /instruction.faload]
+  [daload /instruction.daload]
+  [aaload /instruction.aaload]
+  [baload /instruction.baload]
+  [caload /instruction.caload]
+  [saload /instruction.saload]
+
+  [iastore /instruction.iastore]
+  [lastore /instruction.lastore]
+  [fastore /instruction.fastore]
+  [dastore /instruction.dastore]
+  [aastore /instruction.aastore]
+  [bastore /instruction.bastore]
+  [castore /instruction.castore]
+  [sastore /instruction.sastore]
+
+  [iadd /instruction.iadd]
+  [isub /instruction.isub]
+  [imul /instruction.imul]
+  [idiv /instruction.idiv]
+  [irem /instruction.irem]
+  [ineg /instruction.ineg]
+  [ishl /instruction.ishl]
+  [ishr /instruction.ishr]
+  [iushr /instruction.iushr]
+  [iand /instruction.iand]
+  [ior /instruction.ior]
+  [ixor /instruction.ixor]
+
+  [ladd /instruction.ladd]
+  [lsub /instruction.lsub]
+  [lmul /instruction.lmul]
+  [ldiv /instruction.ldiv]
+  [lrem /instruction.lrem]
+  [lneg /instruction.lneg]
+  [land /instruction.land]
+  [lor /instruction.lor]
+  [lxor /instruction.lxor]
+  
+  [fadd /instruction.fadd]
+  [fsub /instruction.fsub]
+  [fmul /instruction.fmul]
+  [fdiv /instruction.fdiv]
+  [frem /instruction.frem]
+  [fneg /instruction.fneg]
+  
+  [dadd /instruction.dadd]
+  [dsub /instruction.dsub]
+  [dmul /instruction.dmul]
+  [ddiv /instruction.ddiv]
+  [drem /instruction.drem]
+  [dneg /instruction.dneg]
+
+  [lshl /instruction.lshl]
+  [lshr /instruction.lshr]
+  [lushr /instruction.lushr]
+
+  [l2i /instruction.l2i]
+  [l2f /instruction.l2f]
+  [l2d /instruction.l2d]
+  
+  [f2i /instruction.f2i]
+  [f2l /instruction.f2l]
+  [f2d /instruction.f2d]
+  
+  [d2i /instruction.d2i]
+  [d2l /instruction.d2l]
+  [d2f /instruction.d2f]
+
+  [i2l /instruction.i2l]
+  [i2f /instruction.i2f]
+  [i2d /instruction.i2d]
+  [i2b /instruction.i2b]
+  [i2c /instruction.i2c]
+  [i2s /instruction.i2s]
+
+  [lcmp /instruction.lcmp]
+  
+  [fcmpl /instruction.fcmpl]
+  [fcmpg /instruction.fcmpg]
+
+  [dcmpl /instruction.dcmpl]
+  [dcmpg /instruction.dcmpg]
+
+  [ireturn /instruction.ireturn]
+  [lreturn /instruction.lreturn]
+  [freturn /instruction.freturn]
+  [dreturn /instruction.dreturn]
+  [areturn /instruction.areturn]
+  [return /instruction.return]
+
+  [arraylength /instruction.arraylength]
+  
+  [athrow /instruction.athrow]
+  
+  [monitorenter /instruction.monitorenter]
+  [monitorexit /instruction.monitorexit]
+  )
+
+(def: #export (bipush byte)
+  (-> U1 (Program Any))
+  (function (_ [pool tracker])
+    [[pool tracker]
+     [(function.constant (#error.Success (/instruction.bipush byte)))
+      []]]))
+
+(def: (lift on-pool)
+  (All [a]
+    (-> (State Pool a)
+        (Program a)))
+  (function (_ [pool tracker])
+    (let [[pool' output] (state.run pool on-pool)]
+      [[pool' tracker]
+       [..partial-identity
+        output]])))
+
+(def: max-u1
+  (|> //unsigned.max-u1 //unsigned.nat //unsigned.u2))
+
+(template [<name> <type> <constant> <ldc>]
+  [(def: #export (<name> value)
+     (-> <type> (Program Any))
+     (do ..monad
+       [index (..lift (<constant> value))
+        #let [index' (//index.number index)]]
+       (..nullary (if (:: //unsigned.order < ..max-u1 index')
+                    (/instruction.ldc (|> index' //unsigned.nat //unsigned.u1))
+                    (<ldc> index)))))]
+
+  [ldc/long //constant.Long //constant/pool.long /instruction.ldc2-w/long]
+  [ldc/double //constant.Double //constant/pool.double /instruction.ldc2-w/double]
+  )
+
+(template [<name> <instruction> <input>]
+  [(def: #export <name>
+     (-> <input> (Program Any))
+     (|>> <instruction> nullary))]
+
+  [iload /instruction.iload Local]
+  [lload /instruction.lload Local]
+  [fload /instruction.fload Local]
+  [dload /instruction.dload Local]
+  [aload /instruction.aload Local]
+
+  [istore /instruction.istore Local]
+  [lstore /instruction.lstore Local]
+  [fstore /instruction.fstore Local]
+  [dstore /instruction.dstore Local]
+  [astore /instruction.astore Local]
+
+  [ret /instruction.ret Local]
+
+  [newarray /instruction.newarray Primitive-Array-Type]
+
+  [sipush /instruction.sipush U2]
+  )
+
+(exception: #export (unknown-label {label Label})
+  (exception.report
+   ["Label" (%.nat label)]))
+
+(exception: #export (cannot-do-a-big-jump {label Label}
+                                          {@from Address}
+                                          {jump Big-Jump})
+  (exception.report
+   ["Label" (%.nat label)]
+   ["Start" (%.nat @from)]
+   ["Target" (|> jump //unsigned.nat .int %.int)]))
+
+(def: (jump @from @to)
+  (-> Address Address (Either Jump Big-Jump))
+  (let [jump (.int (n/- @to @from))
+        big? (n/> (//unsigned.nat //unsigned.max-u2)
+                  (.nat (i/* (if (i/>= +0 jump)
+                               +1
+                               -1)
+                             jump)))]
+    (if big?
+      (#.Right (//unsigned.u4 (.nat jump)))
+      (#.Left (//unsigned.u2 (.nat jump))))))
+
+(template [<name> <instruction>]
+  [(def: #export (<name> label)
+     (-> Label (Program Any))
+     (function (_ [pool tracker])
+       (let [@from (get@ #program-counter tracker)]
+         [[pool tracker]
+          [(function (_ resolver)
+             (case (dictionary.get label resolver)
+               (#.Some @to)
+               (case (jump @from @to)
+                 (#.Left jump)
+                 (#error.Success (<instruction> jump))
+
+                 (#.Right jump)
+                 (exception.throw ..cannot-do-a-big-jump [label @from jump]))
+
+               #.None
+               (exception.throw ..unknown-label [label])))
+           []]])))]
+
+  [ifeq /instruction.ifeq]
+  [ifne /instruction.ifne]
+  [iflt /instruction.iflt]
+  [ifge /instruction.ifge]
+  [ifgt /instruction.ifgt]
+  [ifle /instruction.ifle]
+  
+  [if-icmpeq /instruction.if-icmpeq]
+  [if-icmpne /instruction.if-icmpne]
+  [if-icmplt /instruction.if-icmplt]
+  [if-icmpge /instruction.if-icmpge]
+  [if-icmpgt /instruction.if-icmpgt]
+  [if-icmple /instruction.if-icmple]
+  
+  [if-acmpeq /instruction.if-acmpeq]
+  [if-acmpne /instruction.if-acmpne]
+  
+  [ifnull /instruction.ifnull]
+  [ifnonnull /instruction.ifnonnull]
+  )
+
+(template [<name> <normal-instruction> <wide-instruction>]
+  [(def: #export (<name> label)
+     (-> Label (Program Any))
+     (function (_ [pool tracker])
+       (let [@from (get@ #program-counter tracker)]
+         [[pool tracker]
+          [(function (_ resolver)
+             (case (dictionary.get label resolver)
+               (#.Some @to)
+               (case (jump @from @to)
+                 (#.Left jump)
+                 (#error.Success (<normal-instruction> jump))
+
+                 (#.Right jump)
+                 (#error.Success (<wide-instruction> jump)))
+
+               #.None
+               (exception.throw ..unknown-label [label])))
+           []]])))]
+
+  [goto /instruction.goto /instruction.goto-w]
+  [jsr /instruction.jsr /instruction.jsr-w]
+  )
+
+(template [<name> <instruction>]
+  [(def: #export (<name> class)
+     (-> UTF8 (Program Any))
+     (do ..monad
+       ## TODO: Make sure it"s impossible to have indexes greater than U2.
+       [index (..lift (//constant/pool.class class))]
+       (..nullary (<instruction> index))))]
+
+  [new /instruction.new]
+  [anewarray /instruction.anewarray]
+  [checkcast /instruction.checkcast]
+  [instanceof /instruction.instanceof]
+  )
+
+(def: #export (iinc register increase)
+  (-> Local U1 (Program Any))
+  (..nullary (/instruction.iinc register increase)))
+
+(def: #export (multianewarray class count)
+  (-> UTF8 U1 (Program Any))
+  (do ..monad
+    [index (..lift (//constant/pool.class class))]
+    (..nullary (/instruction.multianewarray index count))))
diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index fcb2c1be7..373801405 100644
--- a/stdlib/source/lux/target/jvm/program/instruction.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -20,7 +20,7 @@
   ["." // #_
    ["#." resources (#+ Resources)]
    ["/" condition (#+ Environment Condition Local) ("#@." monoid)]
-   ["#." label (#+ Label Wide-Label)]
+   ["#." jump (#+ Jump Big-Jump)]
    ["/#" // #_
     ["#." index (#+ Index)]
     ["#." descriptor (#+ Field Method)]
@@ -362,7 +362,7 @@
                               ["B1" return 0]
                               )
                   <jumps> (template [<code> <name> <input-size> <output-size>]
-                            [[<code> <name> [[label Label]] [label] <input-size> <output-size> []]]
+                            [[<code> <name> [[jump Jump]] [jump] <input-size> <output-size> []]]
 
                             ["99" ifeq 2 0]
                             ["9A" ifne 2 0]
@@ -475,8 +475,8 @@
       ["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 []]]]
+     [["C8" goto-w [[jump Big-Jump]] [jump] 0 0 []]
+      ["C9" jsr-w [[jump Big-Jump]] [jump] 0 1 []]]]
 
     [..binary/11 3
      [["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]]
diff --git a/stdlib/source/lux/target/jvm/program/label.lux b/stdlib/source/lux/target/jvm/program/jump.lux
index 7aaff5739..49a4e42ea 100644
--- a/stdlib/source/lux/target/jvm/program/label.lux
+++ b/stdlib/source/lux/target/jvm/program/jump.lux
@@ -6,7 +6,7 @@
    [encoding
     ["#." unsigned (#+ U2 U4)]]])
 
-(type: #export Label U2)
+(type: #export Jump U2)
 
 (def: #export equivalence
   ///unsigned.equivalence)
@@ -17,4 +17,4 @@
 (def: #export writer
   ///unsigned.u2-writer)
 
-(type: #export Wide-Label U4)
+(type: #export Big-Jump U4)