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

(.require
 [library
  [lux (.except Type Label int try except)
   ["[0]" ffi (.only import)]
   [abstract
    [monoid (.only Monoid)]
    [functor (.only Functor)]
    ["[0]" monad (.only Monad do)]]
   [control
    ["[0]" writer (.only Writer)]
    ["[0]" state (.only +State)]
    ["[0]" maybe]
    ["[0]" try (.only Try) (.use "[1]#[0]" monad)]
    ["[0]" exception (.only exception)]]
   [data
    ["[0]" product]
    [text
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" dictionary (.only Dictionary)]
     ["[0]" sequence (.only Sequence)]]]
   [math
    [number
     ["n" nat]
     ["i" int]
     ["[0]" i32 (.only I32)]]]
   [meta
    [macro
     ["^" pattern]
     ["[0]" template]]]]]
 ["[0]" /
  ["_" instruction (.only Primitive_Array_Type Instruction Estimator) (.use "[1]#[0]" monoid)]
  ["[1][0]" address (.only Address)]
  ["[1][0]" jump (.only Jump Big_Jump)]
  ["[1][0]" environment (.only Environment)
   [limit
    ["/[0]" registry (.only Register Registry)]
    ["/[0]" stack (.only Stack)]]]
  ["/[1]" //
   ["[1][0]" index (.only Index)]
   [encoding
    ["[1][0]" name]
    ["[1][0]" unsigned (.only U1 U2)]
    ["[1][0]" signed (.only S1 S2 S4)]]
   ["[1][0]" constant (.only UTF8)
    ["[1]/[0]" pool (.only Pool Resource)]]
   [attribute
    [code
     ["[1][0]" exception (.only Exception)]]]
   ["[0]" type (.only Type)
    [category (.only Class Object Value' Value Return' Return Method)]
    ["[0]" reflection]
    ["[0]" parser]]]])

(type .public Label
  Nat)

(type .public Resolver
  (Dictionary Label [Stack (Maybe Address)]))

(type .public Tracker
  (Record
   [#program_counter Address
    #next Label
    #known Resolver]))

(def fresh
  Tracker
  [#program_counter /address.start
   #next 0
   #known (dictionary.empty n.hash)])

(type .public Relative
  (-> Resolver (Try [(Sequence Exception) Instruction])))

(def no_exceptions
  (Sequence Exception)
  sequence.empty)

(def relative#identity
  Relative
  (function (_ _)
    {try.#Success [..no_exceptions _.empty]}))

(def try|do
  (template (_ <binding> <term> <then>)
    [(.case <term>
       {try.#Success <binding>}
       <then>

       failure
       (as_expected failure))]))

(def try|in
  (template (_ <it>)
    [{try.#Success <it>}]))

(def (relative#composite left right)
  (-> Relative Relative Relative)
  (cond (same? ..relative#identity left)
        right

        (same? ..relative#identity right)
        left

        ... else
        (function (_ resolver)
          (<| (try|do [left_exceptions left_instruction] (left resolver))
              (try|do [right_exceptions right_instruction] (right resolver))
              (try|in [(at sequence.monoid composite left_exceptions right_exceptions)
                       (_#composite left_instruction right_instruction)])))))

(def relative_monoid
  (Monoid Relative)
  (implementation
   (def identity ..relative#identity)
   (def composite ..relative#composite)))

(type .public (Bytecode a)
  (+State Try [Pool Environment Tracker] (Writer Relative a)))

(def .public new_label
  (Bytecode Label)
  (function (_ [pool environment tracker])
    {try.#Success [[pool
                    environment
                    (revised #next ++ tracker)]
                   [..relative#identity
                    (the #next tracker)]]}))

(exception .public (label_has_already_been_set [label Label])
  (exception.report
   "Label" (%.nat label)))

(exception .public (mismatched_environments [instruction Symbol
                                             label Label
                                             address Address
                                             expected Stack
                                             actual Stack])
  (exception.report
   "Instruction" (%.symbol instruction)
   "Label" (%.nat label)
   "Address" (/address.text address)
   "Expected" (/stack.text expected)
   "Actual" (/stack.text actual)))

(def .public (set? label)
  (-> Label (Bytecode (Maybe [Stack Address])))
  (function (_ state)
    (let [[pool environment tracker] state]
      {try.#Success [state
                     [..relative#identity
                      (case (dictionary.value label (the #known tracker))
                        {.#Some [expected {.#Some address}]}
                        {.#Some [expected address]}
                        
                        _
                        {.#None})]]})))

(def .public (acknowledged? label)
  (-> Label (Bytecode (Maybe Stack)))
  (function (_ state)
    (let [[pool environment tracker] state]
      {try.#Success [state
                     [..relative#identity
                      (case (dictionary.value label (the #known tracker))
                        {.#Some [expected {.#None}]}
                        {.#Some expected}

                        _
                        {.#None})]]})))

(def .public stack
  (Bytecode (Maybe Stack))
  (function (_ state)
    (let [[pool environment tracker] state]
      {try.#Success [state
                     [..relative#identity
                      (the /environment.#stack environment)]]})))

(with_expansions [<success> (these (try|in [[pool
                                             environment
                                             (revised #known
                                                      (dictionary.has label [actual {.#Some @here}])
                                                      tracker)]
                                            [..relative#identity
                                             []]]))]
  (def .public (set_label label)
    (-> Label (Bytecode Any))
    (function (_ [pool environment tracker])
      (let [@here (the #program_counter tracker)]
        (case (dictionary.value label (the #known tracker))
          {.#Some [expected {.#Some address}]}
          (exception.except ..label_has_already_been_set [label])
          
          {.#Some [expected {.#None}]}
          (<| (try|do [actual environment] (/environment.continue expected environment))
              <success>)

          ... {.#None}
          _
          (<| (try|do [actual environment] (/environment.continue (|> environment
                                                                      (the /environment.#stack)
                                                                      (maybe.else /stack.empty))
                                                                  environment))
              <success>))))))

(def .public functor
  (Functor Bytecode)
  (implementation
   (def (each $ it)
     (function (_ state)
       (case (it state)
         {try.#Success [state' [relative it]]}
         {try.#Success [state' [relative ($ it)]]}
         
         ... {try.#Failure error}
         failure
         (as_expected failure))))))

(def .public monad
  (Monad Bytecode)
  (implementation
   (def functor ..functor)

   (def (in it)
     (function (_ state)
       {try.#Success [state [relative#identity it]]}))

   (def (conjoint ^^it)
     (function (_ state)
       (case (^^it state)
         {try.#Success [state' [left ^it]]}
         (case (^it state')
           {try.#Success [state'' [right it]]}
           {try.#Success [state'' [(relative#composite left right) it]]}
           
           ... {try.#Failure error}
           failure
           (as_expected failure))
         
         ... {try.#Failure error}
         failure
         (as_expected failure))))))

(def .public (when_continuous it)
  (-> (Bytecode Any) (Bytecode Any))
  (do ..monad
    [stack ..stack]
    (.case stack
      {.#Some _}
      it

      ... {.#None}
      _
      (in []))))

(def .public (when_acknowledged @ it)
  (-> Label (Bytecode Any) (Bytecode Any))
  (do ..monad
    [?@ (..acknowledged? @)]
    (.case ?@
      {.#Some _}
      it

      ... {.#None}
      _
      (in []))))

(def .public (failure error)
  (-> Text Bytecode)
  (function (_ _)
    {try.#Failure error}))

(def .public (except exception value)
  (All (_ e) (-> (exception.Exception e) e Bytecode))
  (..failure (exception.error exception value)))

(def .public (resolve environment bytecode)
  (All (_ a) (-> Environment (Bytecode a) (Resource [Environment (Sequence Exception) Instruction a])))
  (function (_ pool)
    (<| (try|do [[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh]))
        (try|do [exceptions instruction] (relative (the #known tracker)))
        (try|in [pool [environment exceptions instruction output]]))))

(def (step estimator counter)
  (-> Estimator Address (Try Address))
  (/address.move (estimator counter) counter))

(def (bytecode consumption production registry [estimator bytecode] input)
  (All (_ a) (-> U2 U2 Registry [Estimator (-> [a] Instruction)] a (Bytecode Any)))
  (function (_ [pool environment tracker])
    (<| (try|do environment' (|> environment
                                 (/environment.consumes consumption)
                                 (monad.then try.monad (|>> (/environment.produces production)
                                                            (try#each (/environment.has registry))
                                                            try#conjoint))))
        (try|do program_counter' (step estimator (the #program_counter tracker)))
        (try|in [[pool
                  environment'
                  (has #program_counter program_counter' tracker)]
                 [(function (_ _)
                    (try|in [..no_exceptions (bytecode input)]))
                  []]]))))

(with_template [<name> <frames>]
  [(def <name> U2
     (|> <frames> //unsigned.u2 try.trusted))]

  [$0 0]
  [$1 1]
  [$2 2]
  [$3 3]
  [$4 4]
  [$5 5]
  [$6 6]
  )

(with_template [<name> <registry>]
  [(def <name> Registry (|> <registry> //unsigned.u2 try.trusted /registry.registry))]

  [@_ 0]
  [@0 1]
  [@1 2]
  [@2 3]
  [@3 4]
  [@4 5]
  )

(with_template [<name> <consumption> <production> <registry> <instruction>]
  [(def .public <name>
     (Bytecode Any)
     (..bytecode <consumption>
                 <production>
                 <registry>
                 <instruction>
                 []))]

  [nop $0 $0 @_ _.nop]
  
  [aconst_null $0 $1 @_ _.aconst_null]

  [iconst_m1 $0 $1 @_ _.iconst_m1]
  [iconst_0 $0 $1 @_ _.iconst_0]
  [iconst_1 $0 $1 @_ _.iconst_1]
  [iconst_2 $0 $1 @_ _.iconst_2]
  [iconst_3 $0 $1 @_ _.iconst_3]
  [iconst_4 $0 $1 @_ _.iconst_4]
  [iconst_5 $0 $1 @_ _.iconst_5]

  [lconst_0 $0 $2 @_ _.lconst_0]
  [lconst_1 $0 $2 @_ _.lconst_1]

  [fconst_0 $0 $1 @_ _.fconst_0]
  [fconst_1 $0 $1 @_ _.fconst_1]
  [fconst_2 $0 $1 @_ _.fconst_2]
  
  [dconst_0 $0 $2 @_ _.dconst_0]
  [dconst_1 $0 $2 @_ _.dconst_1]

  [pop $1 $0 @_ _.pop]
  [pop2 $2 $0 @_ _.pop2]
  
  [dup $1 $2 @_ _.dup]
  [dup_x1 $2 $3 @_ _.dup_x1]
  [dup_x2 $3 $4 @_ _.dup_x2]
  [dup2 $2 $4 @_ _.dup2]
  [dup2_x1 $3 $5 @_ _.dup2_x1]
  [dup2_x2 $4 $6 @_ _.dup2_x2]
  
  [swap $2 $2 @_ _.swap]

  [iaload $2 $1 @_ _.iaload]
  [laload $2 $2 @_ _.laload]
  [faload $2 $1 @_ _.faload]
  [daload $2 $2 @_ _.daload]
  [aaload $2 $1 @_ _.aaload]
  [baload $2 $1 @_ _.baload]
  [caload $2 $1 @_ _.caload]
  [saload $2 $1 @_ _.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 $0 @_ _.iastore]
  [lastore $4 $0 @_ _.lastore]
  [fastore $3 $0 @_ _.fastore]
  [dastore $4 $0 @_ _.dastore]
  [aastore $3 $0 @_ _.aastore]
  [bastore $3 $0 @_ _.bastore]
  [castore $3 $0 @_ _.castore]
  [sastore $3 $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 @_ _.iadd]
  [isub $2 $1 @_ _.isub]
  [imul $2 $1 @_ _.imul]
  [idiv $2 $1 @_ _.idiv]
  [irem $2 $1 @_ _.irem]
  [ineg $1 $1 @_ _.ineg]
  [iand $2 $1 @_ _.iand]
  [ior $2 $1 @_ _.ior]
  [ixor $2 $1 @_ _.ixor]
  [ishl $2 $1 @_ _.ishl]
  [ishr $2 $1 @_ _.ishr]
  [iushr $2 $1 @_ _.iushr]

  [ladd $4 $2 @_ _.ladd]
  [lsub $4 $2 @_ _.lsub]
  [lmul $4 $2 @_ _.lmul]
  [ldiv $4 $2 @_ _.ldiv]
  [lrem $4 $2 @_ _.lrem]
  [lneg $2 $2 @_ _.lneg]
  [land $4 $2 @_ _.land]
  [lor $4 $2 @_ _.lor]
  [lxor $4 $2 @_ _.lxor]
  [lshl $3 $2 @_ _.lshl]
  [lshr $3 $2 @_ _.lshr]
  [lushr $3 $2 @_ _.lushr]
  
  [fadd $2 $1 @_ _.fadd]
  [fsub $2 $1 @_ _.fsub]
  [fmul $2 $1 @_ _.fmul]
  [fdiv $2 $1 @_ _.fdiv]
  [frem $2 $1 @_ _.frem]
  [fneg $1 $1 @_ _.fneg]
  
  [dadd $4 $2 @_ _.dadd]
  [dsub $4 $2 @_ _.dsub]
  [dmul $4 $2 @_ _.dmul]
  [ddiv $4 $2 @_ _.ddiv]
  [drem $4 $2 @_ _.drem]
  [dneg $2 $2 @_ _.dneg]

  [l2i $2 $1 @_ _.l2i]
  [l2f $2 $1 @_ _.l2f]
  [l2d $2 $2 @_ _.l2d]
  
  [f2i $1 $1 @_ _.f2i]
  [f2l $1 $2 @_ _.f2l]
  [f2d $1 $2 @_ _.f2d]
  
  [d2i $2 $1 @_ _.d2i]
  [d2l $2 $2 @_ _.d2l]
  [d2f $2 $1 @_ _.d2f]

  [i2l $1 $2 @_ _.i2l]
  [i2f $1 $1 @_ _.i2f]
  [i2d $1 $2 @_ _.i2d]
  [i2b $1 $1 @_ _.i2b]
  [i2c $1 $1 @_ _.i2c]
  [i2s $1 $1 @_ _.i2s]

  [lcmp $4 $1 @_ _.lcmp]
  
  [fcmpl $2 $1 @_ _.fcmpl]
  [fcmpg $2 $1 @_ _.fcmpg]

  [dcmpl $4 $1 @_ _.dcmpl]
  [dcmpg $4 $1 @_ _.dcmpg]

  [arraylength $1 $1 @_ _.arraylength]
  
  [monitorenter $1 $0 @_ _.monitorenter]
  [monitorexit $1 $0 @_ _.monitorexit]
  )

(def discontinuity!
  (Bytecode Any)
  (function (_ [pool environment tracker])
    (<| (try|do _ (/environment.stack environment))
        (try|in [[pool
                  (/environment.discontinue environment)
                  tracker]
                 [..relative#identity
                  []]]))))

(with_template [<name> <consumption> <instruction>]
  [(def .public <name>
     (Bytecode Any)
     (do ..monad
       [_ (..bytecode <consumption> $0 @_ <instruction> [])]
       ..discontinuity!))]

  [ireturn $1 _.ireturn]
  [lreturn $2 _.lreturn]
  [freturn $1 _.freturn]
  [dreturn $2 _.dreturn]
  [areturn $1 _.areturn]
  [return $0 _.return]

  [athrow $1 _.athrow]
  )

(def .public (bipush byte)
  (-> S1 (Bytecode Any))
  (..bytecode $0 $1 @_ _.bipush [byte]))

(def (lifted resource)
  (All (_ a)
    (-> (Resource a)
        (Bytecode a)))
  (function (_ [pool environment tracker])
    (<| (try|do [pool' output] (resource pool))
        (try|in [[pool' environment tracker]
                 [..relative#identity
                  output]]))))

(def .public (string value)
  (-> //constant.UTF8 (Bytecode Any))
  (do ..monad
    [index (..lifted (//constant/pool.string value))]
    (case (|> index //index.value //unsigned.value //unsigned.u1)
      {try.#Success index}
      (..bytecode $0 $1 @_ _.ldc [index])

      {try.#Failure _}
      (..bytecode $0 $1 @_ _.ldc_w/string [index]))))

(import java/lang/Float
  "[1]::[0]"
  ("static" floatToRawIntBits "manual" [float] int))

(import java/lang/Double
  "[1]::[0]"
  ("static" doubleToRawLongBits "manual" [double] long))

(with_template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
  [(def .public (<name> value)
     (-> <type> (Bytecode Any))
     (case (|> value <to_lux>)
       (^.with_template [<special> <instruction>]
         [<special> (..bytecode $0 $1 @_ <instruction> [])])
       <specializations>
       
       _ (do ..monad
           [index (..lifted (<constant> (<constructor> value)))]
           (case (|> index //index.value //unsigned.value //unsigned.u1)
             {try.#Success index}
             (..bytecode $0 $1 @_ _.ldc [index])

             {try.#Failure _}
             (..bytecode $0 $1 @_ <wide> [index])))))]

  [int I32 //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])]
  )

(def (arbitrary_float value)
  (-> java/lang/Float (Bytecode Any))
  (do ..monad
    [index (..lifted (//constant/pool.float (//constant.float value)))]
    (case (|> index //index.value //unsigned.value //unsigned.u1)
      {try.#Success index}
      (..bytecode $0 $1 @_ _.ldc [index])

      {try.#Failure _}
      (..bytecode $0 $1 @_ _.ldc_w/float [index]))))

(def float_bits
  (-> java/lang/Float Int)
  (|>> java/lang/Float::floatToRawIntBits
       ffi.int_to_long
       (as Int)))

(def negative_zero_float_bits
  (|> -0.0 (as java/lang/Double) ffi.double_to_float ..float_bits))

(def .public (float value)
  (-> java/lang/Float (Bytecode Any))
  (if (i.= ..negative_zero_float_bits
           (..float_bits value))
    (..arbitrary_float value)
    (case (|> value ffi.float_to_double (as Frac))
      (^.with_template [<special> <instruction>]
        [<special> (..bytecode $0 $1 @_ <instruction> [])])
      ([+0.0 _.fconst_0]
       [+1.0 _.fconst_1]
       [+2.0 _.fconst_2])
      
      _ (..arbitrary_float value))))

(with_template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
  [(def .public (<name> value)
     (-> <type> (Bytecode Any))
     (case (|> value <to_lux>)
       (^.with_template [<special> <instruction>]
         [<special> (..bytecode $0 $2 @_ <instruction> [])])
       <specializations>
       
       _ (do ..monad
           [index (..lifted (<constant> (<constructor> value)))]
           (..bytecode $0 $2 @_ <wide> [index]))))]

  [long Int //constant.long //constant/pool.long _.ldc2_w/long
   (<|)
   ([+0 _.lconst_0]
    [+1 _.lconst_1])]
  )

(def (arbitrary_double value)
  (-> java/lang/Double (Bytecode Any))
  (do ..monad
    [index (..lifted (//constant/pool.double (//constant.double (as Frac value))))]
    (..bytecode $0 $2 @_ _.ldc2_w/double [index])))

(def double_bits
  (-> java/lang/Double Int)
  (|>> java/lang/Double::doubleToRawLongBits
       (as Int)))

(def negative_zero_double_bits
  (..double_bits (as java/lang/Double -0.0)))

(def .public (double value)
  (-> java/lang/Double (Bytecode Any))
  (if (i.= ..negative_zero_double_bits
           (..double_bits value))
    (..arbitrary_double value)
    (case (as Frac value)
      (^.with_template [<special> <instruction>]
        [<special> (..bytecode $0 $2 @_ <instruction> [])])
      ([+0.0 _.dconst_0]
       [+1.0 _.dconst_1])
      
      _ (..arbitrary_double value))))

(exception .public (invalid_register [id Nat])
  (exception.report
   "ID" (%.nat id)))

(def (register id)
  (-> Nat (Bytecode Register))
  (case (//unsigned.u1 id)
    {try.#Success register}
    (at ..monad in register)
    
    {try.#Failure error}
    (..except ..invalid_register [id])))

(with_template [<for> <size> <name> <general> <specials>]
  [(def .public (<name> local)
     (-> Nat (Bytecode Any))
     (with_expansions [<specials>' (template.spliced <specials>)]
       (`` (case local
             (,, (with_template [<case> <instruction> <registry>]
                   [<case> (..bytecode $0 <size> <registry> <instruction> [])]
                   
                   <specials>'))
             _ (do ..monad
                 [local (..register local)]
                 (..bytecode $0 <size> (<for> local) <general> [local]))))))]
  
  [/registry.for $1 iload _.iload
   [[0 _.iload_0 @0]
    [1 _.iload_1 @1]
    [2 _.iload_2 @2]
    [3 _.iload_3 @3]]]
  [/registry.for_wide $2 lload _.lload
   [[0 _.lload_0 @1]
    [1 _.lload_1 @2]
    [2 _.lload_2 @3]
    [3 _.lload_3 @4]]]
  [/registry.for $1 fload _.fload
   [[0 _.fload_0 @0]
    [1 _.fload_1 @1]
    [2 _.fload_2 @2]
    [3 _.fload_3 @3]]]
  [/registry.for_wide $2 dload _.dload
   [[0 _.dload_0 @1]
    [1 _.dload_1 @2]
    [2 _.dload_2 @3]
    [3 _.dload_3 @4]]]
  [/registry.for $1 aload _.aload
   [[0 _.aload_0 @0]
    [1 _.aload_1 @1]
    [2 _.aload_2 @2]
    [3 _.aload_3 @3]]]
  )

(with_template [<for> <size> <name> <general> <specials>]
  [(def .public (<name> local)
     (-> Nat (Bytecode Any))
     (with_expansions [<specials>' (template.spliced <specials>)]
       (`` (case local
             (,, (with_template [<case> <instruction> <registry>]
                   [<case> (..bytecode <size> $0 <registry> <instruction> [])]
                   
                   <specials>'))
             _ (do ..monad
                 [local (..register local)]
                 (..bytecode <size> $0 (<for> local) <general> [local]))))))]
  
  [/registry.for $1 istore _.istore
   [[0 _.istore_0 @0]
    [1 _.istore_1 @1]
    [2 _.istore_2 @2]
    [3 _.istore_3 @3]]]
  [/registry.for_wide $2 lstore _.lstore
   [[0 _.lstore_0 @1]
    [1 _.lstore_1 @2]
    [2 _.lstore_2 @3]
    [3 _.lstore_3 @4]]]
  [/registry.for $1 fstore _.fstore
   [[0 _.fstore_0 @0]
    [1 _.fstore_1 @1]
    [2 _.fstore_2 @2]
    [3 _.fstore_3 @3]]]
  [/registry.for_wide $2 dstore _.dstore
   [[0 _.dstore_0 @1]
    [1 _.dstore_1 @2]
    [2 _.dstore_2 @3]
    [3 _.dstore_3 @4]]]
  [/registry.for $1 astore _.astore
   [[0 _.astore_0 @0]
    [1 _.astore_1 @1]
    [2 _.astore_2 @2]
    [3 _.astore_3 @3]]]
  )

(with_template [<consumption> <production> <name> <instruction> <input>]
  [(def .public <name>
     (-> <input> (Bytecode Any))
     (..bytecode <consumption> <production> @_ <instruction>))]
  
  [$1 $1 newarray _.newarray Primitive_Array_Type]
  [$0 $1 sipush _.sipush S2]
  )

(exception .public (unknown_label [label Label])
  (exception.report
   "Label" (%.nat label)))

(exception .public (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))
  (<| (try|do jump (try#each //signed.value
                             (/address.jump @from @to)))
      (let [big? (or (i.> (//signed.value //signed.maximum/2)
                          jump)
                     (i.< (//signed.value //signed.minimum/2)
                          jump))])
      (if big?
        (try#each (|>> {.#Left}) (//signed.s4 jump))
        (try#each (|>> {.#Right}) (//signed.s2 jump)))))

(exception .public (unset_label [label Label])
  (exception.report
   "Label" (%.nat label)))

(def (resolve_label label resolver)
  (-> Label Resolver (Try [Stack Address]))
  (case (dictionary.value label resolver)
    {.#Some [actual {.#Some address}]}
    {try.#Success [actual address]}

    {.#Some [actual {.#None}]}
    (exception.except ..unset_label [label])
    
    ... {.#None}
    _
    (exception.except ..unknown_label [label])))

(def (acknowledge_label stack label tracker)
  (-> Stack Label Tracker Tracker)
  (case (dictionary.value label (the #known tracker))
    {.#Some _}
    tracker

    ... {.#None}
    _
    (revised #known (dictionary.has label [stack {.#None}]) tracker)))

(with_template [<consumption> <name> <instruction>]
  [(def .public (<name> label)
     (-> Label (Bytecode Any))
     (let [[estimator bytecode] <instruction>]
       (function (_ [pool environment tracker])
         (<| (let [@here (the #program_counter tracker)])
             (try|do environment' (|> environment
                                      (/environment.consumes <consumption>)))
             (try|do actual (/environment.stack environment'))
             (try|do program_counter' (step estimator @here))
             (try|in (let [@from @here]
                       [[pool
                         environment'
                         (|> tracker
                             (..acknowledge_label actual label)
                             (has #program_counter program_counter'))]
                        [(function (_ resolver)
                           (<| (try|do [expected @to] (..resolve_label label resolver))
                               (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
                                                              (at /stack.equivalence = expected actual)))
                               (try|do jump (..jump @from @to))
                               (case jump
                                 {.#Left jump}
                                 (exception.except ..cannot_do_a_big_jump [label @from jump])

                                 {.#Right jump}
                                 (try|in [..no_exceptions (bytecode jump)]))))
                         []]]))))))]

  [$1 ifeq _.ifeq]
  [$1 ifne _.ifne]
  [$1 iflt _.iflt]
  [$1 ifge _.ifge]
  [$1 ifgt _.ifgt]
  [$1 ifle _.ifle]
  
  [$1 ifnull _.ifnull]
  [$1 ifnonnull _.ifnonnull]

  [$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]
  )

(with_template [<name> <instruction> <on_long_jump> <on_short_jump>]
  [(def .public (<name> label)
     (-> Label (Bytecode Any))
     (let [[estimator bytecode] <instruction>]
       (function (_ [pool environment tracker])
         (<| (try|do actual (/environment.stack environment))
             (let [@here (the #program_counter tracker)])
             (try|do program_counter' (step estimator @here))
             (try|in (let [@from @here]
                       [[pool
                         (/environment.discontinue environment)
                         (|> tracker
                             (..acknowledge_label actual label)
                             (has #program_counter program_counter'))]
                        [(function (_ resolver)
                           (case (dictionary.value label resolver)
                             {.#Some [expected {.#Some @to}]}
                             (<| (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
                                                                (at /stack.equivalence = expected actual)))
                                 (try|do jump (..jump @from @to))
                                 (case jump
                                   {.#Left jump}
                                   <on_long_jump>

                                   {.#Right jump}
                                   <on_short_jump>))

                             {.#Some [expected {.#None}]}
                             (exception.except ..unset_label [label])

                             ... {.#None}
                             _
                             (exception.except ..unknown_label [label])))
                         []]]))))))]

  [goto _.goto
   (exception.except ..cannot_do_a_big_jump [label @from jump])
   (try|in [..no_exceptions (bytecode jump)])]
  [goto_w _.goto_w
   (try|in [..no_exceptions (bytecode jump)])
   (try|in [..no_exceptions (bytecode (/jump.lifted jump))])]
  )

(def (big_jump jump)
  (-> Any_Jump Big_Jump)
  (case jump
    {.#Left big}
    big

    {.#Right small}
    (/jump.lifted small)))

(exception .public invalid_tableswitch)

(def .public (tableswitch minimum default [at_minimum afterwards])
  (-> S4 Label [Label (List Label)] (Bytecode Any))
  (let [[estimator bytecode] _.tableswitch]
    (function (_ [pool environment tracker])
      (<| (try|do environment' (|> environment
                                   (/environment.consumes $1)))
          (try|do actual (/environment.stack environment'))
          (try|do program_counter' (step (estimator (list.size afterwards)) (the #program_counter tracker)))
          (try|in (let [@from (the #program_counter tracker)]
                    [[pool
                      environment'
                      (|> (list#mix (..acknowledge_label actual) tracker (list.partial default at_minimum afterwards))
                          (has #program_counter program_counter'))]
                     [(function (_ resolver)
                        (let [get (is (-> Label (Maybe [Stack (Maybe Address)]))
                                      (function (_ label)
                                        (dictionary.value label resolver)))]
                          (case (do [! maybe.monad]
                                  [@default (|> default get (monad.then ! product.right))
                                   @at_minimum (|> at_minimum get (monad.then ! product.right))]
                                  (|> afterwards
                                      (monad.each ! get)
                                      (monad.then ! (monad.each ! product.right))
                                      (at ! each (|>> [@default @at_minimum]))))
                            {.#Some [@default @at_minimum @afterwards]}
                            (<| (try|do >default (try#each ..big_jump (..jump @from @default)))
                                (try|do >at_minimum (try#each ..big_jump (..jump @from @at_minimum)))
                                (try|do >afterwards (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump))
                                                                @afterwards))
                                (try|in [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])]))

                            ... {.#None}
                            _
                            (exception.except ..invalid_tableswitch []))))
                      []]]))))))

(exception .public invalid_lookupswitch)

(def .public (lookupswitch default cases)
  (-> Label (List [S4 Label]) (Bytecode Any))
  (let [cases (list.sorted (function (_ [left _] [right _])
                             (i.< (//signed.value left)
                                  (//signed.value right)))
                           cases)
        [estimator bytecode] _.lookupswitch]
    (function (_ [pool environment tracker])
      (<| (try|do environment' (|> environment
                                   (/environment.consumes $1)))
          (try|do actual (/environment.stack environment'))
          (try|do program_counter' (step (estimator (list.size cases)) (the #program_counter tracker)))
          (try|in (let [@from (the #program_counter tracker)]
                    [[pool
                      environment'
                      (|> (list#mix (..acknowledge_label actual) tracker (list.partial default (list#each product.right cases)))
                          (has #program_counter program_counter'))]
                     [(function (_ resolver)
                        (let [get (is (-> Label (Maybe [Stack (Maybe Address)]))
                                      (function (_ label)
                                        (dictionary.value label resolver)))]
                          (case (do [! maybe.monad]
                                  [@default (|> default get (monad.then ! product.right))]
                                  (|> cases
                                      (monad.each ! (|>> product.right get))
                                      (monad.then ! (monad.each ! product.right))
                                      (at ! each (|>> [@default]))))
                            {.#Some [@default @cases]}
                            (<| (try|do >default (try#each ..big_jump (..jump @from @default)))
                                (try|do >cases (|> @cases
                                                   (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump)))
                                                   (try#each (|>> (list.zipped_2 (list#each product.left cases))))))
                                (try|in [..no_exceptions (bytecode >default >cases)]))

                            ... {.#None}
                            _
                            (exception.except ..invalid_lookupswitch []))))
                      []]]))))))

(def reflection
  (All (_ category)
    (-> (Type (<| Return' Value' category)) Text))
  (|>> type.reflection reflection.reflection))

(with_template [<consumption> <production> <name> <category> <instruction>]
  [(def .public (<name> class)
     (-> (Type <category>) (Bytecode Any))
     (do ..monad
       [... TODO: Make sure it's impossible to have indexes greater than U2.
        index (..lifted (//constant/pool.class (//name.internal (..reflection class))))]
       (..bytecode <consumption> <production> @_ <instruction> [index])))]

  [$0 $1 new Class _.new]
  [$1 $1 anewarray Object _.anewarray]
  [$1 $1 checkcast Object _.checkcast]
  [$1 $1 instanceof Object _.instanceof]
  )

(def .public (iinc register increase)
  (-> Nat U1 (Bytecode Any))
  (do ..monad
    [register (..register register)]
    (..bytecode $0 $0 (/registry.for register) _.iinc [register increase])))

(exception .public (multiarray_cannot_be_zero_dimensional [class (Type Object)])
  (exception.report
   "Class" (..reflection class)))

(def .public (multianewarray class dimensions)
  (-> (Type Object) U1 (Bytecode Any))
  (do ..monad
    [_ (is (Bytecode Any)
           (case (|> dimensions //unsigned.value)
             0 (..except ..multiarray_cannot_be_zero_dimensional [class])
             _ (in [])))
     index (..lifted (//constant/pool.class (//name.internal (..reflection class))))]
    (..bytecode (//unsigned.lifted/2 dimensions) $1 @_ _.multianewarray [index dimensions])))

(def (type_size type)
  (-> (Type Return) Nat)
  (cond (same? type.void type)
        0

        (or (same? type.long type)
            (same? type.double type))
        2

        ... else
        1))

(with_template [<static?> <name> <instruction> <method>]
  [(def .public (<name> class method type)
     (-> (Type Class) Text (Type Method) (Bytecode Any))
     (let [[type_variables inputs output exceptions] (parser.method type)]
       (do ..monad
         [index (<| ..lifted
                    (<method> (..reflection class))
                    [//constant/pool.#name method
                     //constant/pool.#descriptor (type.descriptor type)])
          .let [consumption (|> inputs
                                (list#each ..type_size)
                                (list#mix n.+ (if <static?> 0 1))
                                //unsigned.u1
                                try.trusted)
                production (|> output ..type_size //unsigned.u1 try.trusted)]]
         (..bytecode (//unsigned.lifted/2 consumption)
                     (//unsigned.lifted/2 production)
                     @_
                     <instruction> [index consumption production]))))]

  [#1 invokestatic _.invokestatic //constant/pool.method]
  [#0 invokevirtual _.invokevirtual //constant/pool.method]
  [#0 invokespecial _.invokespecial //constant/pool.method]
  [#0 invokeinterface _.invokeinterface //constant/pool.interface_method]
  )

(with_template [<consumption> <name> <1> <2>]
  [(def .public (<name> class field type)
     (-> (Type Class) Text (Type Value) (Bytecode Any))
     (do ..monad
       [index (<| ..lifted
                  (//constant/pool.field (..reflection class))
                  [//constant/pool.#name field
                   //constant/pool.#descriptor (type.descriptor type)])]
       (if (or (same? type.long type)
               (same? type.double type))
         (..bytecode <consumption> $2 @_ <2> [index])
         (..bytecode <consumption> $1 @_ <1> [index]))))]

  [$0 getstatic _.getstatic/1 _.getstatic/2]
  [$1 getfield  _.getfield/1  _.getfield/2]
  )

(with_template [<name> <consumption/1> <1> <consumption/2> <2>]
  [(def .public (<name> class field type)
     (-> (Type Class) Text (Type Value) (Bytecode Any))
     (do [! ..monad]
       [index (<| ..lifted
                  (//constant/pool.field (..reflection class))
                  [//constant/pool.#name field
                   //constant/pool.#descriptor (type.descriptor type)])]
       (if (or (same? type.long type)
               (same? type.double type))
         (..bytecode <consumption/2> $0 @_ <2> [index])
         (..bytecode <consumption/1> $0 @_ <1> [index]))))]

  [putstatic $1 _.putstatic/1 $2 _.putstatic/2]
  [putfield  $2 _.putfield/1  $3 _.putfield/2]
  )

(exception .public (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 .public (try @start @end @handler catch)
  (-> Label Label Label (Type Class) (Bytecode Any))
  (do ..monad
    [@catch (..lifted (//constant/pool.class (//name.internal (..reflection catch))))]
    (function (_ [pool environment tracker])
      {try.#Success
       [[pool
         environment
         (..acknowledge_label /stack.catch @handler tracker)]
        [(function (_ resolver)
           (<| (try|do [_ @start] (..resolve_label @start resolver))
               (try|do [_ @end] (..resolve_label @end resolver))
               (try|do _ (if (/address.after? @start @end)
                           (try|in [])
                           (exception.except ..invalid_range_for_try [@start @end])))
               (try|do [_ @handler] (..resolve_label @handler resolver))
               (try|in [(sequence.sequence
                         [//exception.#start @start
                          //exception.#end @end
                          //exception.#handler @handler
                          //exception.#catch @catch])
                        _.empty])))
         []]]})))

(def .public (composite pre post)
  (All (_ pre post)
    (-> (Bytecode pre) (Bytecode post) (Bytecode post)))
  (function (_ state)
    (case (pre state)
      {try.#Success [state' [left _]]}
      (case (post state')
        {try.#Success [state'' [right it]]}
        {try.#Success [state'' [(relative#composite left right) it]]}

        ... {try.#Failure error}
        failure
        failure)
      
      ... {try.#Failure error}
      failure
      (as_expected failure))))