WIP: Major refactoring of JVM bytecode machinery.

1 files changed, 823 insertions, 0 deletions

diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
new file mode 100644
index 000000000..7dc974658
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/bytecode.lux
@@ -0,0 +1,823 @@
+(.module:
+  [lux (#- Type int)
+   ["." host]
+   [abstract
+    [monoid (#+ Monoid)]
+    ["." monad (#+ Monad do)]]
+   [control
+    [writer (#+ Writer)]
+    ["." state (#+ State')]
+    ["." function]
+    ["." try (#+ Try)]
+    ["." exception (#+ exception:)]]
+   [data
+    ["." product]
+    ["." maybe]
+    [text
+     ["%" format (#+ format)]]
+    [number
+     ["n" nat]
+     ["i" int]
+     ["." i32]]
+    [collection
+     ["." list ("#@." functor fold)]
+     ["." dictionary (#+ Dictionary)]
+     ["." row (#+ Row)]]]
+   [macro
+    ["." template]]]
+  ["." / #_
+   ["#." address (#+ Address)]
+   ["#." jump (#+ Jump Big-Jump)]
+   ["_" instruction (#+ Primitive-Array-Type Instruction Estimator) ("#@." monoid)]
+   ["#." environment (#+ Environment)
+    [limit
+     [registry (#+ Register)]]]
+   ["/#" // #_
+    ["#." index (#+ Index)]
+    [encoding
+     ["#." name]
+     ["#." unsigned (#+ U1 U2)]
+     ["#." signed (#+ S4)]]
+    ["#." constant (#+ UTF8)
+     ["#/." pool (#+ Pool Resource)]]
+    [attribute
+     [code
+      ["#." exception (#+ Exception)]]]
+    ["." type (#+ Type)
+     [category (#+ Class Object Value' Value Return' Return Method)]
+     ["." reflection]
+     ["." parser]]]])
+
+(type: #export Label Nat)
+
+(type: #export Resolver (Dictionary Label Address))
+
+(type: #export Tracker
+  {#program-counter Address
+   #next Label
+   #known Resolver})
+
+(def: fresh
+  Tracker
+  {#program-counter /address.start
+   #next 0
+   #known (dictionary.new n.hash)})
+
+(type: #export Relative
+  (-> Resolver (Try [(Row Exception) Instruction])))
+
+(def: no-exceptions
+  (Row Exception)
+  row.empty)
+
+(def: relative-identity
+  Relative
+  (function.constant (#try.Success [..no-exceptions _.empty])))
+
+(structure: relative-monoid
+  (Monoid Relative)
+
+  (def: identity ..relative-identity)
+
+  (def: (compose left right)
+    (cond (is? ..relative-identity left)
+          right
+
+          (is? ..relative-identity right)
+          left
+
+          ## else
+          (function (_ resolver)
+            (do try.monad
+              [[left-exceptions left-instruction] (left resolver)
+               [right-exceptions right-instruction] (right resolver)]
+              (wrap [(:: row.monoid compose left-exceptions right-exceptions)
+                     (_@compose left-instruction right-instruction)]))))))
+
+(type: #export (Bytecode a)
+  (State' Try [Pool Environment Tracker] (Writer Relative a)))
+
+(def: #export new-label
+  (Bytecode Label)
+  (function (_ [pool environment tracker])
+    (#try.Success [[pool
+                    environment
+                    (update@ #next inc tracker)]
+                   [..relative-identity
+                    (get@ #next tracker)]])))
+
+(exception: #export (label-has-already-been-set {label Label})
+  (exception.report
+   ["Label" (%.nat label)]))
+
+(def: #export (set-label label)
+  (-> Label (Bytecode Any))
+  (function (_ [pool environment tracker])
+    (if (dictionary.contains? label (get@ #known tracker))
+      (exception.throw ..label-has-already-been-set [label])
+      (#try.Success [[pool
+                      environment
+                      (update@ #known
+                               (dictionary.put label (get@ #program-counter tracker))
+                               tracker)]
+                     [..relative-identity
+                      []]]))))
+
+(def: #export monad
+  (Monad Bytecode)
+  (:coerce (Monad Bytecode)
+           (state.with try.monad)))
+
+(def: #export (resolve bytecode)
+  (All [a] (-> (Bytecode a) (Resource [Environment (Row Exception) Instruction a])))
+  (function (_ pool)
+    (do try.monad
+      [[[pool environment tracker] [relative output]] (bytecode [pool /environment.start ..fresh])
+       [exceptions instruction] (relative (get@ #known tracker))]
+      (wrap [pool [environment exceptions instruction output]]))))
+
+(def: (step estimator counter)
+  (-> Estimator Address (Try Address))
+  (/address.move (estimator counter) counter))
+
+(def: (bytecode consumption production last-register [estimator bytecode] input)
+  (All [a] (-> U2 U2 Register [Estimator (-> [a] Instruction)] [a] (Bytecode Any)))
+  (function (_ [pool environment tracker])
+    (do try.monad
+      [environment' (|> environment
+                        (/environment.consumes consumption)
+                        (monad.bind @ (/environment.produces production))
+                        (monad.bind @ (/environment.has last-register)))
+       program-counter' (step estimator (get@ #program-counter tracker))]
+      (wrap [[pool
+              environment'
+              (set@ #program-counter program-counter' tracker)]
+             [(function.constant (#try.Success [..no-exceptions (bytecode input)]))
+              []]]))))
+
+(template [<name> <frames>]
+  [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))]
+
+  [$0 0]
+  [$1 1]
+  [$2 2]
+  [$3 3]
+  [$4 4]
+  [$5 5]
+  [$6 6]
+  )
+
+(template [<name> <registry>]
+  [(def: <name> Register (|> <registry> //unsigned.u1 try.assume))]
+
+  [@0 0]
+  [@1 1]
+  [@2 2]
+  [@3 3]
+  [@4 4]
+  )
+
+(template [<name> <consumption> <production> <last-register> <instruction>]
+  [(def: #export <name>
+     (Bytecode Any)
+     (..bytecode <consumption>
+                 <production>
+                 <last-register>
+                 <instruction>
+                 []))]
+
+  [nop $0 $0 @0 _.nop]
+  
+  [aconst-null $0 $1 @0 _.aconst-null]
+
+  [iconst-m1 $0 $1 @0 _.iconst-m1]
+  [iconst-0 $0 $1 @0 _.iconst-0]
+  [iconst-1 $0 $1 @0 _.iconst-1]
+  [iconst-2 $0 $1 @0 _.iconst-2]
+  [iconst-3 $0 $1 @0 _.iconst-3]
+  [iconst-4 $0 $1 @0 _.iconst-4]
+  [iconst-5 $0 $1 @0 _.iconst-5]
+
+  [lconst-0 $0 $2 @0 _.lconst-0]
+  [lconst-1 $0 $2 @0 _.lconst-1]
+
+  [fconst-0 $0 $1 @0 _.fconst-0]
+  [fconst-1 $0 $1 @0 _.fconst-1]
+  [fconst-2 $0 $1 @0 _.fconst-2]
+  
+  [dconst-0 $0 $2 @0 _.dconst-0]
+  [dconst-1 $0 $2 @0 _.dconst-1]
+
+  [pop $1 $0 @0 _.pop]
+  [pop2 $2 $0 @0 _.pop2]
+  
+  [dup $1 $2 @0 _.dup]
+  [dup-x1 $2 $3 @0 _.dup-x1]
+  [dup-x2 $3 $4 @0 _.dup-x2]
+  [dup2 $2 $4 @0 _.dup2]
+  [dup2-x1 $3 $5 @0 _.dup2-x1]
+  [dup2-x2 $4 $6 @0 _.dup2-x2]
+  
+  [swap $2 $2 @0 _.swap]
+
+  [iaload $2 $1 @0 _.iaload]
+  [laload $2 $2 @0 _.laload]
+  [faload $2 $1 @0 _.faload]
+  [daload $2 $2 @0 _.daload]
+  [aaload $2 $1 @0 _.aaload]
+  [baload $2 $1 @0 _.baload]
+  [caload $2 $1 @0 _.caload]
+  [saload $2 $1 @0 _.saload]
+
+  [iload-0 $0 $1 @0 _.iload-0]
+  [iload-1 $0 $1 @1 _.iload-1]
+  [iload-2 $0 $1 @2 _.iload-2]
+  [iload-3 $0 $1 @3 _.iload-3]
+
+  [lload-0 $0 $2 @1 _.lload-0]
+  [lload-1 $0 $2 @2 _.lload-1]
+  [lload-2 $0 $2 @3 _.lload-2]
+  [lload-3 $0 $2 @4 _.lload-3]
+  
+  [fload-0 $0 $1 @0 _.fload-0]
+  [fload-1 $0 $1 @1 _.fload-1]
+  [fload-2 $0 $1 @2 _.fload-2]
+  [fload-3 $0 $1 @3 _.fload-3]
+  
+  [dload-0 $0 $2 @1 _.dload-0]
+  [dload-1 $0 $2 @2 _.dload-1]
+  [dload-2 $0 $2 @3 _.dload-2]
+  [dload-3 $0 $2 @4 _.dload-3]
+  
+  [aload-0 $0 $1 @0 _.aload-0]
+  [aload-1 $0 $1 @1 _.aload-1]
+  [aload-2 $0 $1 @2 _.aload-2]
+  [aload-3 $0 $1 @3 _.aload-3]
+
+  [iastore $3 $1 @0 _.iastore]
+  [lastore $4 $1 @0 _.lastore]
+  [fastore $3 $1 @0 _.fastore]
+  [dastore $4 $1 @0 _.dastore]
+  [aastore $3 $1 @0 _.aastore]
+  [bastore $3 $1 @0 _.bastore]
+  [castore $3 $1 @0 _.castore]
+  [sastore $3 $1 @0 _.sastore]
+
+  [istore-0 $1 $0 @0 _.istore-0]
+  [istore-1 $1 $0 @1 _.istore-1]
+  [istore-2 $1 $0 @2 _.istore-2]
+  [istore-3 $1 $0 @3 _.istore-3]
+
+  [lstore-0 $2 $0 @1 _.lstore-0]
+  [lstore-1 $2 $0 @2 _.lstore-1]
+  [lstore-2 $2 $0 @3 _.lstore-2]
+  [lstore-3 $2 $0 @4 _.lstore-3]
+
+  [fstore-0 $1 $0 @0 _.fstore-0]
+  [fstore-1 $1 $0 @1 _.fstore-1]
+  [fstore-2 $1 $0 @2 _.fstore-2]
+  [fstore-3 $1 $0 @3 _.fstore-3]
+
+  [dstore-0 $2 $0 @1 _.dstore-0]
+  [dstore-1 $2 $0 @2 _.dstore-1]
+  [dstore-2 $2 $0 @3 _.dstore-2]
+  [dstore-3 $2 $0 @4 _.dstore-3]
+  
+  [astore-0 $1 $0 @0 _.astore-0]
+  [astore-1 $1 $0 @1 _.astore-1]
+  [astore-2 $1 $0 @2 _.astore-2]
+  [astore-3 $1 $0 @3 _.astore-3]
+
+  [iadd $2 $1 @0 _.iadd]
+  [isub $2 $1 @0 _.isub]
+  [imul $2 $1 @0 _.imul]
+  [idiv $2 $1 @0 _.idiv]
+  [irem $2 $1 @0 _.irem]
+  [ineg $2 $1 @0 _.ineg]
+  [ishl $2 $1 @0 _.ishl]
+  [ishr $2 $1 @0 _.ishr]
+  [iushr $2 $1 @0 _.iushr]
+  [iand $2 $1 @0 _.iand]
+  [ior $2 $1 @0 _.ior]
+  [ixor $2 $1 @0 _.ixor]
+
+  [ladd $4 $2 @0 _.ladd]
+  [lsub $4 $2 @0 _.lsub]
+  [lmul $4 $2 @0 _.lmul]
+  [ldiv $4 $2 @0 _.ldiv]
+  [lrem $4 $2 @0 _.lrem]
+  [lneg $4 $2 @0 _.lneg]
+  [land $4 $2 @0 _.land]
+  [lor $4 $2 @0 _.lor]
+  [lxor $4 $2 @0 _.lxor]
+  [lshl $3 $2 @0 _.lshl]
+  [lshr $3 $2 @0 _.lshr]
+  [lushr $3 $2 @0 _.lushr]
+  
+  [fadd $2 $1 @0 _.fadd]
+  [fsub $2 $1 @0 _.fsub]
+  [fmul $2 $1 @0 _.fmul]
+  [fdiv $2 $1 @0 _.fdiv]
+  [frem $2 $1 @0 _.frem]
+  [fneg $2 $1 @0 _.fneg]
+  
+  [dadd $4 $2 @0 _.dadd]
+  [dsub $4 $2 @0 _.dsub]
+  [dmul $4 $2 @0 _.dmul]
+  [ddiv $4 $2 @0 _.ddiv]
+  [drem $4 $2 @0 _.drem]
+  [dneg $4 $2 @0 _.dneg]
+
+  [l2i $2 $1 @0 _.l2i]
+  [l2f $2 $1 @0 _.l2f]
+  [l2d $2 $2 @0 _.l2d]
+  
+  [f2i $1 $1 @0 _.f2i]
+  [f2l $1 $2 @0 _.f2l]
+  [f2d $1 $2 @0 _.f2d]
+  
+  [d2i $2 $1 @0 _.d2i]
+  [d2l $2 $2 @0 _.d2l]
+  [d2f $2 $1 @0 _.d2f]
+
+  [i2l $1 $2 @0 _.i2l]
+  [i2f $1 $1 @0 _.i2f]
+  [i2d $1 $2 @0 _.i2d]
+  [i2b $1 $1 @0 _.i2b]
+  [i2c $1 $1 @0 _.i2c]
+  [i2s $1 $1 @0 _.i2s]
+
+  [lcmp $4 $1 @0 _.lcmp]
+  
+  [fcmpl $2 $1 @0 _.fcmpl]
+  [fcmpg $2 $1 @0 _.fcmpg]
+
+  [dcmpl $4 $1 @0 _.dcmpl]
+  [dcmpg $4 $1 @0 _.dcmpg]
+
+  [ireturn $1 $0 @0 _.ireturn]
+  [lreturn $2 $0 @0 _.lreturn]
+  [freturn $1 $0 @0 _.freturn]
+  [dreturn $2 $0 @0 _.dreturn]
+  [areturn $1 $0 @0 _.areturn]
+  [return $0 $0 @0 _.return]
+
+  [arraylength $1 $1 @0 _.arraylength]
+  
+  [athrow $1 $0 @0 _.athrow]
+  
+  [monitorenter $1 $0 @0 _.monitorenter]
+  [monitorexit $1 $0 @0 _.monitorexit]
+  )
+
+(def: #export (bipush byte)
+  (-> U1 (Bytecode Any))
+  (..bytecode $0 $1 @0 _.bipush [byte]))
+
+(def: (lift resource)
+  (All [a]
+    (-> (Resource a)
+        (Bytecode a)))
+  (function (_ [pool environment tracker])
+    (do try.monad
+      [[pool' output] (resource pool)]
+      (wrap [[pool' environment tracker]
+             [..relative-identity
+              output]]))))
+
+(def: #export (string value)
+  (-> //constant.UTF8 (Bytecode Any))
+  (do ..monad
+    [index (..lift (//constant/pool.string value))]
+    (case (|> index //index.value //unsigned.value //unsigned.u1)
+      (#try.Success index)
+      (..bytecode $0 $1 @0 _.ldc [index])
+
+      (#try.Failure _)
+      (..bytecode $0 $1 @0 _.ldc-w/string [index]))))
+
+(template [<size> <name> <type> <constant> <ldc> <to-lux> <specializations>]
+  [(def: #export (<name> value)
+     (-> <type> (Bytecode Any))
+     (case (|> value //constant.value <to-lux>)
+       (^template [<special> <instruction>]
+         <special> (..bytecode $0 <size> @0 <instruction> []))
+       <specializations>
+       
+       _ (do ..monad
+           [index (..lift (<constant> value))]
+           (..bytecode $0 <size> @0 <ldc> [index]))))]
+
+  [$1 int //constant.Integer //constant/pool.integer _.ldc-w/integer
+   (<| .int i32.i64)
+   ([-1 _.iconst-m1]
+    [+0 _.iconst-0]
+    [+1 _.iconst-1]
+    [+2 _.iconst-2]
+    [+3 _.iconst-3]
+    [+4 _.iconst-4]
+    [+5 _.iconst-5])]
+  [$2 long //constant.Long //constant/pool.long _.ldc2-w/long
+   (<|)
+   ([+0 _.lconst-0]
+    [+1 _.lconst-1])]
+  [$1 float //constant.Float //constant/pool.float _.ldc-w/float
+   (<| host.float-to-double)
+   ([+0.0 _.fconst-0]
+    [+1.0 _.fconst-1]
+    [+2.0 _.fconst-2])]
+  [$2 double //constant.Double //constant/pool.double _.ldc2-w/double
+   (<|)
+   ([+0.0 _.fconst-0]
+    [+1.0 _.fconst-1])]
+  )
+
+(template [<size> <name> <general> <specials>]
+  [(def: #export (<name> local)
+     (-> Register (Bytecode Any))
+     (with-expansions [<specials>' (template.splice <specials>)]
+       (`` (case (//unsigned.value local)
+             (~~ (template [<case> <instruction> <last-register>]
+                   [<case> (..bytecode $0 <size> <last-register> <instruction> [])]
+                   
+                   <specials>'))
+             _ (..bytecode $0 <size> local <general> [local])))))]
+  
+  [$1 iload _.iload
+   [[0 _.iload-0 @0]
+    [1 _.iload-1 @1]
+    [2 _.iload-2 @2]
+    [3 _.iload-3 @3]]]
+  [$2 lload _.lload
+   [[0 _.lload-0 @1]
+    [1 _.lload-1 @2]
+    [2 _.lload-2 @3]
+    [3 _.lload-3 @4]]]
+  [$1 fload _.fload
+   [[0 _.fload-0 @0]
+    [1 _.fload-1 @1]
+    [2 _.fload-2 @2]
+    [3 _.fload-3 @3]]]
+  [$2 dload _.dload
+   [[0 _.dload-0 @1]
+    [1 _.dload-1 @2]
+    [2 _.dload-2 @3]
+    [3 _.dload-3 @4]]]
+  [$1 aload _.aload
+   [[0 _.aload-0 @0]
+    [1 _.aload-1 @1]
+    [2 _.aload-2 @2]
+    [3 _.aload-3 @3]]]
+  )
+
+(template [<size> <name> <general> <specials>]
+  [(def: #export (<name> local)
+     (-> Register (Bytecode Any))
+     (with-expansions [<specials>' (template.splice <specials>)]
+       (`` (case (//unsigned.value local)
+             (~~ (template [<case> <instruction> <last-register>]
+                   [<case> (..bytecode <size> $0 <last-register> <instruction> [])]
+                   
+                   <specials>'))
+             _ (..bytecode <size> $0 local <general> [local])))))]
+  
+  [$1 istore _.istore
+   [[0 _.istore-0 @0]
+    [1 _.istore-1 @1]
+    [2 _.istore-2 @2]
+    [3 _.istore-3 @3]]]
+  [$2 lstore _.lstore
+   [[0 _.lstore-0 @1]
+    [1 _.lstore-1 @2]
+    [2 _.lstore-2 @3]
+    [3 _.lstore-3 @4]]]
+  [$1 fstore _.fstore
+   [[0 _.fstore-0 @0]
+    [1 _.fstore-1 @1]
+    [2 _.fstore-2 @2]
+    [3 _.fstore-3 @3]]]
+  [$2 dstore _.dstore
+   [[0 _.dstore-0 @1]
+    [1 _.dstore-1 @2]
+    [2 _.dstore-2 @3]
+    [3 _.dstore-3 @4]]]
+  [$1 astore _.astore
+   [[0 _.astore-0 @0]
+    [1 _.astore-1 @1]
+    [2 _.astore-2 @2]
+    [3 _.astore-3 @3]]]
+  )
+
+(template [<consumption> <production> <name> <instruction> <input>]
+  [(def: #export <name>
+     (-> <input> (Bytecode Any))
+     (..bytecode <consumption> <production> @0 <instruction>))]
+  
+  [$0 $0 ret _.ret Register]
+  [$1 $1 newarray _.newarray Primitive-Array-Type]
+  [$0 $1 sipush _.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" (|> @from /address.value //unsigned.value %.nat)]
+   ["Target" (|> jump //signed.value %.int)]))
+
+(type: Any-Jump (Either Big-Jump Jump))
+
+(def: (jump @from @to)
+  (-> Address Address (Try Any-Jump))
+  (do try.monad
+    [jump (:: @ map //signed.value
+              (/address.jump @from @to))]
+    (let [big? (n.> (//unsigned.value //unsigned.maximum/2)
+                    (.nat (i.* (if (i.>= +0 jump)
+                                 +1
+                                 -1)
+                               jump)))]
+      (if big?
+        (:: @ map (|>> #.Left) (//signed.s4 jump))
+        (:: @ map (|>> #.Right) (//signed.s2 jump))))))
+
+(def: (resolve-label label resolver)
+  (-> Label Resolver (Try Address))
+  (case (dictionary.get label resolver)
+    (#.Some address)
+    (#try.Success address)
+
+    #.None
+    (exception.throw ..unknown-label [label])))
+
+(template [<consumption> <name> <instruction>]
+  [(def: #export (<name> label)
+     (-> Label (Bytecode Any))
+     (let [[estimator bytecode] <instruction>]
+       (function (_ [pool environment tracker])
+         (do try.monad
+           [environment' (|> environment
+                             (/environment.consumes <consumption>))
+            program-counter' (step estimator (get@ #program-counter tracker))]
+           (wrap (let [@from (get@ #program-counter tracker)]
+                   [[pool environment' (set@ #program-counter program-counter' tracker)]
+                    [(function (_ resolver)
+                       (do try.monad
+                         [@to (..resolve-label label resolver)
+                          jump (..jump @from @to)]
+                         (case jump
+                           (#.Left jump)
+                           (exception.throw ..cannot-do-a-big-jump [label @from jump])
+
+                           (#.Right jump)
+                           (#try.Success [..no-exceptions (bytecode jump)]))))
+                     []]]))))))]
+
+  [$1 ifeq _.ifeq]
+  [$1 ifne _.ifne]
+  [$1 iflt _.iflt]
+  [$1 ifge _.ifge]
+  [$1 ifgt _.ifgt]
+  [$1 ifle _.ifle]
+  
+  [$2 if-icmpeq _.if-icmpeq]
+  [$2 if-icmpne _.if-icmpne]
+  [$2 if-icmplt _.if-icmplt]
+  [$2 if-icmpge _.if-icmpge]
+  [$2 if-icmpgt _.if-icmpgt]
+  [$2 if-icmple _.if-icmple]
+  
+  [$2 if-acmpeq _.if-acmpeq]
+  [$2 if-acmpne _.if-acmpne]
+  
+  [$1 ifnull _.ifnull]
+  [$1 ifnonnull _.ifnonnull]
+  )
+
+(template [<production> <name> <bytecode>]
+  [(def: #export (<name> label)
+     (-> Label (Bytecode Any))
+     (let [[estimator bytecode] <bytecode>]
+       (function (_ [pool environment tracker])
+         (do try.monad
+           [environment' (|> environment
+                             (/environment.produces <production>))
+            program-counter' (step estimator (get@ #program-counter tracker))]
+           (wrap (let [@from (get@ #program-counter tracker)]
+                   [[pool environment' (set@ #program-counter program-counter' tracker)]
+                    [(function (_ resolver)
+                       (case (dictionary.get label resolver)
+                         (#.Some @to)
+                         (do try.monad
+                           [jump (..jump @from @to)]
+                           (case jump
+                             (#.Left jump)
+                             (exception.throw ..cannot-do-a-big-jump [label @from jump])
+
+                             (#.Right jump)
+                             (#try.Success [..no-exceptions (bytecode jump)])))
+
+                         #.None
+                         (exception.throw ..unknown-label [label])))
+                     []]]))))))]
+
+  [$0 goto _.goto]
+  [$1 jsr _.jsr]
+  )
+
+(def: (big-jump jump)
+  (-> Any-Jump Big-Jump)
+  (case jump
+    (#.Left big)
+    big
+
+    (#.Right small)
+    (/jump.lift small)))
+
+(exception: #export invalid-tableswitch)
+
+(def: #export (tableswitch minimum default cases)
+  (-> S4 Label (List Label) (Bytecode Any))
+  (let [[estimator bytecode] _.tableswitch]
+    (function (_ [pool environment tracker])
+      (do try.monad
+        [environment' (|> environment
+                          (/environment.consumes $1))
+         program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))]
+        (wrap (let [@from (get@ #program-counter tracker)]
+                [[pool environment' (set@ #program-counter program-counter' tracker)]
+                 [(function (_ resolver)
+                    (let [get (: (-> Label (Maybe Address))
+                                 (function (_ label)
+                                   (dictionary.get label resolver)))]
+                      (case (do maybe.monad
+                              [@default (get default)
+                               @cases (monad.map @ get cases)]
+                              (wrap [@default @cases]))
+                        (#.Some [@default @cases])
+                        (do try.monad
+                          [>default (:: @ map ..big-jump (..jump @from @default))
+                           >cases (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump))
+                                             @cases)]
+                          (#try.Success [..no-exceptions (bytecode minimum >default >cases)]))
+
+                        #.None
+                        (exception.throw ..invalid-tableswitch []))))
+                  []]]))))))
+
+(exception: #export invalid-lookupswitch)
+
+(def: #export (lookupswitch default cases)
+  (-> Label (List [S4 Label]) (Bytecode Any))
+  (let [[estimator bytecode] _.lookupswitch]
+    (function (_ [pool environment tracker])
+      (do try.monad
+        [environment' (|> environment
+                          (/environment.consumes $1))
+         program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))]
+        (wrap (let [@from (get@ #program-counter tracker)]
+                [[pool environment' (set@ #program-counter program-counter' tracker)]
+                 [(function (_ resolver)
+                    (let [get (: (-> Label (Maybe Address))
+                                 (function (_ label)
+                                   (dictionary.get label resolver)))]
+                      (case (do maybe.monad
+                              [@default (get default)
+                               @cases (monad.map @ (|>> product.right get) cases)]
+                              (wrap [@default @cases]))
+                        (#.Some [@default @cases])
+                        (do try.monad
+                          [>default (:: @ map ..big-jump (..jump @from @default))
+                           >cases (|> @cases
+                                      (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump)))
+                                      (:: @ map (|>> (list.zip2 (list@map product.left cases)))))]
+                          (#try.Success [..no-exceptions (bytecode >default >cases)]))
+
+                        #.None
+                        (exception.throw ..invalid-lookupswitch []))))
+                  []]]))))))
+
+(def: reflection
+  (All [category]
+    (-> (Type (<| Return' Value' category)) Text))
+  (|>> type.reflection reflection.reflection))
+
+(template [<consumption> <production> <name> <category> <instruction>]
+  [(def: #export (<name> class)
+     (-> (Type <category>) (Bytecode Any))
+     (do ..monad
+       ## TODO: Make sure it's impossible to have indexes greater than U2.
+       [index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
+       (..bytecode <consumption> <production> @0 <instruction> [index])))]
+
+  [$0 $1 new Class _.new]
+  [$1 $1 anewarray Object _.anewarray]
+  [$1 $1 checkcast Object _.checkcast]
+  [$1 $1 instanceof Object _.instanceof]
+  )
+
+(def: #export (iinc register increase)
+  (-> Register U1 (Bytecode Any))
+  (..bytecode $0 $0 register _.iinc [register increase]))
+
+(def: #export (multianewarray class dimensions)
+  (-> (Type Class) U1 (Bytecode Any))
+  (do ..monad
+    [index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
+    (..bytecode (//unsigned.lift/2 dimensions) $1 @0 _.multianewarray [index dimensions])))
+
+(def: (type-size type)
+  (-> (Type Return) Nat)
+  (cond (is? type.void type)
+        0
+
+        (or (is? type.long type)
+            (is? type.double type))
+        2
+
+        ## else
+        1))
+
+(template [<static?> <name> <instruction>]
+  [(def: #export (<name> class method type)
+     (-> (Type Class) Text (Type Method) (Bytecode Any))
+     (let [[inputs output exceptions] (parser.method type)]
+       (do ..monad
+         [index (<| ..lift
+                    (//constant/pool.method (..reflection class))
+                    {#//constant/pool.name method
+                     #//constant/pool.descriptor (type.descriptor type)})
+          #let [consumption (|> inputs
+                                (list@map ..type-size)
+                                (list@fold n.+ (if <static?> 0 1))
+                                //unsigned.u1
+                                try.assume)
+                production (|> output ..type-size //unsigned.u1 try.assume)]]
+         (..bytecode (//unsigned.lift/2 consumption)
+                     (//unsigned.lift/2 production)
+                     @0
+                     <instruction> [index consumption production]))))]
+
+  [#1 invokestatic _.invokestatic]
+  [#0 invokevirtual _.invokevirtual]
+  [#0 invokespecial _.invokespecial]
+  [#0 invokeinterface _.invokeinterface]
+  )
+
+(template [<consumption> <name> <1> <2>]
+  [(def: #export (<name> class field type)
+     (-> (Type Class) Text (Type Value) (Bytecode Any))
+     (do ..monad
+       [index (<| ..lift
+                  (//constant/pool.field (..reflection class))
+                  {#//constant/pool.name field
+                   #//constant/pool.descriptor (type.descriptor type)})]
+       (if (or (is? type.long type)
+               (is? type.double type))
+         (..bytecode <consumption> $2 @0 <2> [index])
+         (..bytecode <consumption> $1 @0 <1> [index]))))]
+
+  [$0 getstatic _.getstatic/1 _.getstatic/2]
+  [$1 putstatic _.putstatic/1 _.putstatic/2]
+  [$1 getfield _.getfield/1 _.getfield/2]
+  [$2 putfield _.putfield/1 _.putfield/2]
+  )
+
+(exception: #export (invalid-range-for-try {start Address} {end Address})
+  (exception.report
+   ["Start" (|> start /address.value //unsigned.value %.nat)]
+   ["End" (|> end /address.value //unsigned.value %.nat)]))
+
+(def: #export (try @start @end @handler catch)
+  (-> Label Label Label (Type Class) (Bytecode Any))
+  (do ..monad
+    [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))]
+    (function (_ [pool environment tracker])
+      (#try.Success
+       [[pool environment tracker]
+        [(function (_ resolver)
+           (do try.monad
+             [@start (..resolve-label @start resolver)
+              @end (..resolve-label @end resolver)
+              _ (if (/address.after? @start @end)
+                  (wrap [])
+                  (exception.throw ..invalid-range-for-try [@start @end]))
+              @handler (..resolve-label @handler resolver)]
+             (wrap [(row.row {#//exception.start @start
+                              #//exception.end @end
+                              #//exception.handler @handler
+                              #//exception.catch @catch})
+                    _.empty])))
+         []]]))))
+
+(def: #export (compose pre post)
+  (All [pre post]
+    (-> (Bytecode pre) (Bytecode post) (Bytecode post)))
+  (do ..monad
+    [_ pre]
+    post))