path: root/stdlib/source/lux/target/jvm/bytecode.lux

(.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))