diff options
author | Eduardo Julian | 2019-11-07 22:32:32 -0400 |
---|---|---|
committer | Eduardo Julian | 2019-11-07 22:32:32 -0400 |
commit | a23315e79ff58024134e5d20b4a4cb5bd8050152 (patch) | |
tree | a4488a77fba13683eb17e74d69ec701b4d12e4d0 /stdlib/source/lux/target/jvm/bytecode.lux | |
parent | aab604028e117e505bc408f69dc416fe6d9f46a7 (diff) |
WIP: Major refactoring of JVM bytecode machinery.
Diffstat (limited to 'stdlib/source/lux/target/jvm/bytecode.lux')
-rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 823 |
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)) |