From a5a71a224408b6a7a736fd2f4c06646bf5c89fd8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 16 Nov 2019 22:40:58 -0400 Subject: Tests for JVM bytecode machinery. [Part 5] --- stdlib/source/lux.lux | 4 +- stdlib/source/lux/target/jvm/bytecode.lux | 6 +- .../source/lux/target/jvm/bytecode/environment.lux | 21 +- .../lux/target/jvm/bytecode/environment/limit.lux | 25 +- .../jvm/bytecode/environment/limit/registry.lux | 47 +- stdlib/source/lux/target/jvm/instruction.lux | 722 --------------------- .../source/lux/target/jvm/instruction/bytecode.lux | 660 ------------------- stdlib/source/lux/target/jvm/method.lux | 39 +- stdlib/source/lux/target/jvm/modifier.lux | 35 +- stdlib/source/test/lux/target/jvm.lux | 225 +++++-- 10 files changed, 311 insertions(+), 1473 deletions(-) delete mode 100644 stdlib/source/lux/target/jvm/instruction.lux delete mode 100644 stdlib/source/lux/target/jvm/instruction/bytecode.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 6042457fe..c33f025ea 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -3985,7 +3985,9 @@ _ (do meta-monad [current-module current-module-name] - (fail (text@compose "Wrong syntax for import @ " current-module)))))) + (fail ($_ text@compose + "Wrong syntax for import @ " current-module + ..new-line (%code token))))))) imports)] (wrap (list@join imports')))) diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux index 7db2d8e4b..32e29b82f 100644 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -141,11 +141,11 @@ (All [e] (-> (exception.Exception e) e Bytecode)) (..fail (exception.construct exception value))) -(def: #export (resolve bytecode) - (All [a] (-> (Bytecode a) (Resource [Environment (Row Exception) Instruction a]))) +(def: #export (resolve environment bytecode) + (All [a] (-> Environment (Bytecode a) (Resource [Environment (Row Exception) Instruction a]))) (function (_ pool) (do try.monad - [[[pool environment tracker] [relative output]] (bytecode [pool /environment.start ..fresh]) + [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh]) [exceptions instruction] (relative (get@ #known tracker))] (wrap [pool [environment exceptions instruction output]])))) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment.lux b/stdlib/source/lux/target/jvm/bytecode/environment.lux index 70db71c47..51927b96e 100644 --- a/stdlib/source/lux/target/jvm/bytecode/environment.lux +++ b/stdlib/source/lux/target/jvm/bytecode/environment.lux @@ -1,5 +1,5 @@ (.module: - [lux #* + [lux (#- Type static) [abstract [monad (#+ do)] [monoid (#+ Monoid)]] @@ -11,16 +11,25 @@ ["/." registry (#+ Registry)]] [/// [encoding - [unsigned (#+ U2)]]]]) + [unsigned (#+ U2)]] + [type (#+ Type) + [category (#+ Method)]]]]) (type: #export Environment {#limit Limit #stack Stack}) -(def: #export start - Environment - {#limit /limit.start - #stack /stack.empty}) +(template [ ] + [(def: #export ( type) + (-> (Type Method) (Try Environment)) + (do try.monad + [limit ( type)] + (wrap {#limit limit + #stack /stack.empty})))] + + [static /limit.static] + [virtual /limit.virtual] + ) (type: #export Condition (-> Environment (Try Environment))) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux index 2e2312fb5..1bbb40e15 100644 --- a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux +++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux @@ -1,7 +1,10 @@ (.module: - [lux #* + [lux (#- Type static) [abstract + [monad (#+ do)] ["." equivalence (#+ Equivalence)]] + [control + ["." try (#+ Try)]] [data [number ["n" nat]] @@ -9,16 +12,26 @@ ["#" binary (#+ Writer) ("#@." monoid)]]]] ["." / #_ ["#." stack (#+ Stack)] - ["#." registry (#+ Registry)]]) + ["#." registry (#+ Registry)] + [//// + [type (#+ Type) + [category (#+ Method)]]]]) (type: #export Limit {#stack Stack #registry Registry}) -(def: #export start - Limit - {#stack /stack.empty - #registry /registry.empty}) +(template [ ] + [(def: #export ( type) + (-> (Type Method) (Try Limit)) + (do try.monad + [registry ( type)] + (wrap {#stack /stack.empty + #registry registry})))] + + [static /registry.static] + [virtual /registry.virtual] + ) (def: #export length ($_ n.+ diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux index eb3820bfb..3a8bd4482 100644 --- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux +++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux @@ -1,20 +1,30 @@ (.module: - [lux (#- for) + [lux (#- Type for static) [abstract ["." equivalence (#+ Equivalence)]] [control - ["." try]] + ["." try (#+ Try) ("#@." functor)]] [data + [number + ["n" nat]] [format - [binary (#+ Writer)]]] + [binary (#+ Writer)]] + [collection + ["." list ("#@." functor fold)]]] [type abstract]] ["." ///// #_ [encoding - ["#." unsigned (#+ U1 U2)]]]) + ["#." unsigned (#+ U1 U2)]] + ["#." type (#+ Type) + [category (#+ Method)] + ["#/." parser]]]) (type: #export Register U1) +(def: normal 1) +(def: wide 2) + (abstract: #export Registry {} @@ -24,9 +34,28 @@ (-> U2 Registry) (|>> :abstraction)) - (def: #export empty - Registry - (|> 0 /////unsigned.u2 try.assume :abstraction)) + (def: (minimal type) + (-> (Type Method) Nat) + (let [[inputs output exceptions] (/////type/parser.method type)] + (|> inputs + (list@map (function (_ input) + (if (or (is? /////type.long input) + (is? /////type.double input)) + ..wide + ..normal))) + (list@fold n.+ 0)))) + + (template [ ] + [(def: #export + (-> (Type Method) (Try Registry)) + (|>> ..minimal + (n.+ ) + /////unsigned.u2 + (try@map ..registry)))] + + [0 static] + [1 virtual] + ) (def: #export equivalence (Equivalence Registry) @@ -53,8 +82,8 @@ try.assume :abstraction)))] - [for 1] - [for-wide 2] + [for ..normal] + [for-wide ..wide] ) ) diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux deleted file mode 100644 index 210439df3..000000000 --- a/stdlib/source/lux/target/jvm/instruction.lux +++ /dev/null @@ -1,722 +0,0 @@ -(.module: - [lux (#- Type) - ["." host] - [abstract - [monoid (#+ Monoid)] - ["." monad (#+ Monad do)]] - [control - ["." state (#+ State)] - ["." writer (#+ Writer)] - ["." 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)]]]] - ["." / #_ - ["#." condition (#+ Stack Local)] - ["#." address] - ["#." jump (#+ Jump Big-Jump)] - ["_" bytecode (#+ Primitive-Array-Type Bytecode Estimator) ("#@." monoid)] - ["/#" // #_ - ["#." index (#+ Index)] - [encoding - ["#." name] - ["#." unsigned (#+ U1 U2)] - ["#." signed (#+ S4)]] - ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool)]] - [attribute - [code - ["#." exception (#+ Exception)]]] - ["." type (#+ Type) - [category (#+ Class Object Value' Value Return' Return Method)] - ["." reflection] - ["." parser]]]]) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(type: #export Address Nat) - -(type: #export Label Nat) - -(type: #export Resolver (Dictionary Label Address)) - -(type: #export Tracker - {#program-counter Address - #next-label Label - #known-labels Resolver}) - -(def: fresh - Tracker - {#program-counter 0 - #next-label 0 - #known-labels (dictionary.new n.hash)}) - -(type: #export Partial - (-> Resolver (Try [(Row Exception) Bytecode]))) - -(def: no-exceptions - (Row Exception) - row.empty) - -(def: no-bytecode - Bytecode - (|>> #try.Success)) - -(def: partial-identity - Partial - (function.constant (#try.Success [..no-exceptions ..no-bytecode]))) - -(structure: partial-monoid - (Monoid Partial) - - (def: identity ..partial-identity) - - (def: (compose left right) - (cond (is? ..partial-identity left) - right - - (is? ..partial-identity right) - left - - ## else - (function (_ resolver) - (do try.monad - [[left-exceptions left-bytecode] (left resolver) - [right-exceptions right-bytecode] (right resolver)] - (wrap [(:: row.monoid compose left-exceptions right-exceptions) - (_@compose left-bytecode right-bytecode)])))))) - -(type: #export (Instruction a) - (State [Pool Tracker] (Writer Partial a))) - -(def: #export new-label - (Instruction Label) - (function (_ [pool tracker]) - [[pool - (update@ #next-label inc tracker)] - [..partial-identity - (get@ #next-label tracker)]])) - -(def: #export (set-label label) - (-> Label (Instruction Any)) - ## TODO: Throw an exception if trying to set an already-set label! - (function (_ [pool tracker]) - [[pool - (update@ #known-labels - (dictionary.put label (get@ #program-counter tracker)) - tracker)] - [..partial-identity - []]])) - -(def: #export monad - ## TODO: Remove the coercion. It was added because the type-checker - ## seems to have a bug that is being triggered here. - (:coerce (Monad Instruction) - (writer.with ..partial-monoid - (: (Monad (State [Pool Tracker])) - state.monad)))) - -(def: #export (resolve instruction) - (All [a] - (-> (Instruction a) - (State Pool (Try [Bytecode - (Row Exception) - a])))) - (function (_ pool) - (let [[[pool tracker] [partial output]] (state.run [pool ..fresh] instruction)] - [pool (do try.monad - [[exceptions bytecode] (partial (get@ #known-labels tracker))] - (wrap [bytecode exceptions output]))]))) - -(def: (count estimator counter) - (-> Estimator Address Address) - (n.+ (estimator counter) counter)) - -(def: (opcode [estimator bytecode] input) - (All [a] (-> [Estimator (-> [a] Bytecode)] [a] (Instruction Any))) - (function (_ [pool tracker]) - [[pool (update@ #program-counter (count estimator) tracker)] - [(function.constant (#try.Success [..no-exceptions (bytecode input)])) - []]])) - -(template [ ] - [(def: #export (..opcode []))] - - [nop _.nop] - - [aconst-null _.aconst-null] - - [iconst-m1 _.iconst-m1] - [iconst-0 _.iconst-0] - [iconst-1 _.iconst-1] - [iconst-2 _.iconst-2] - [iconst-3 _.iconst-3] - [iconst-4 _.iconst-4] - [iconst-5 _.iconst-5] - - [lconst-0 _.lconst-0] - [lconst-1 _.lconst-1] - - [fconst-0 _.fconst-0] - [fconst-1 _.fconst-1] - [fconst-2 _.fconst-2] - - [dconst-0 _.dconst-0] - [dconst-1 _.dconst-1] - - [pop _.pop] - [pop2 _.pop2] - - [dup _.dup] - [dup-x1 _.dup-x1] - [dup-x2 _.dup-x2] - [dup2 _.dup2] - [dup2-x1 _.dup2-x1] - [dup2-x2 _.dup2-x2] - - [swap _.swap] - - [iaload _.iaload] - [laload _.laload] - [faload _.faload] - [daload _.daload] - [aaload _.aaload] - [baload _.baload] - [caload _.caload] - [saload _.saload] - - [iload-0 _.iload-0] - [iload-1 _.iload-1] - [iload-2 _.iload-2] - [iload-3 _.iload-3] - - [lload-0 _.lload-0] - [lload-1 _.lload-1] - [lload-2 _.lload-2] - [lload-3 _.lload-3] - - [fload-0 _.fload-0] - [fload-1 _.fload-1] - [fload-2 _.fload-2] - [fload-3 _.fload-3] - - [dload-0 _.dload-0] - [dload-1 _.dload-1] - [dload-2 _.dload-2] - [dload-3 _.dload-3] - - [aload-0 _.aload-0] - [aload-1 _.aload-1] - [aload-2 _.aload-2] - [aload-3 _.aload-3] - - [iastore _.iastore] - [lastore _.lastore] - [fastore _.fastore] - [dastore _.dastore] - [aastore _.aastore] - [bastore _.bastore] - [castore _.castore] - [sastore _.sastore] - - [istore-0 _.istore-0] - [istore-1 _.istore-1] - [istore-2 _.istore-2] - [istore-3 _.istore-3] - - [lstore-0 _.lstore-0] - [lstore-1 _.lstore-1] - [lstore-2 _.lstore-2] - [lstore-3 _.lstore-3] - - [fstore-0 _.fstore-0] - [fstore-1 _.fstore-1] - [fstore-2 _.fstore-2] - [fstore-3 _.fstore-3] - - [dstore-0 _.dstore-0] - [dstore-1 _.dstore-1] - [dstore-2 _.dstore-2] - [dstore-3 _.dstore-3] - - [astore-0 _.astore-0] - [astore-1 _.astore-1] - [astore-2 _.astore-2] - [astore-3 _.astore-3] - - [iadd _.iadd] - [isub _.isub] - [imul _.imul] - [idiv _.idiv] - [irem _.irem] - [ineg _.ineg] - [ishl _.ishl] - [ishr _.ishr] - [iushr _.iushr] - [iand _.iand] - [ior _.ior] - [ixor _.ixor] - - [ladd _.ladd] - [lsub _.lsub] - [lmul _.lmul] - [ldiv _.ldiv] - [lrem _.lrem] - [lneg _.lneg] - [land _.land] - [lor _.lor] - [lxor _.lxor] - - [fadd _.fadd] - [fsub _.fsub] - [fmul _.fmul] - [fdiv _.fdiv] - [frem _.frem] - [fneg _.fneg] - - [dadd _.dadd] - [dsub _.dsub] - [dmul _.dmul] - [ddiv _.ddiv] - [drem _.drem] - [dneg _.dneg] - - [lshl _.lshl] - [lshr _.lshr] - [lushr _.lushr] - - [l2i _.l2i] - [l2f _.l2f] - [l2d _.l2d] - - [f2i _.f2i] - [f2l _.f2l] - [f2d _.f2d] - - [d2i _.d2i] - [d2l _.d2l] - [d2f _.d2f] - - [i2l _.i2l] - [i2f _.i2f] - [i2d _.i2d] - [i2b _.i2b] - [i2c _.i2c] - [i2s _.i2s] - - [lcmp _.lcmp] - - [fcmpl _.fcmpl] - [fcmpg _.fcmpg] - - [dcmpl _.dcmpl] - [dcmpg _.dcmpg] - - [ireturn _.ireturn] - [lreturn _.lreturn] - [freturn _.freturn] - [dreturn _.dreturn] - [areturn _.areturn] - [return _.return] - - [arraylength _.arraylength] - - [athrow _.athrow] - - [monitorenter _.monitorenter] - [monitorexit _.monitorexit] - ) - -(def: #export (bipush byte) - (-> U1 (Instruction Any)) - (let [[estimator bytecode] _.bipush] - (function (_ [pool tracker]) - [[pool (update@ #program-counter (count estimator) tracker)] - [(function.constant (#try.Success [..no-exceptions (bytecode byte)])) - []]]))) - -(def: (lift on-pool) - (All [a] - (-> (State Pool a) - (Instruction a))) - (function (_ [pool tracker]) - (let [[pool' output] (state.run pool on-pool)] - [[pool' tracker] - [..partial-identity - output]]))) - -(def: max-u1 - (|> //unsigned.max-u1 //unsigned.nat //unsigned.u2)) - -(def: #export (ldc/string value) - (-> //constant.UTF8 (Instruction Any)) - (do ..monad - [index (..lift (//constant/pool.string value)) - #let [index' (//index.number index)]] - (if (:: //unsigned.order < ..max-u1 index') - (..opcode _.ldc [(|> index' //unsigned.nat //unsigned.u1)]) - (..opcode _.ldc-w/string [index])))) - -(template [ ] - [(def: #export ( value) - (-> (Instruction Any)) - (case (|> value //constant.value ) - (^template [ ] - (..opcode [])) - - - _ (do ..monad - [index (..lift ( value))] - (..opcode [index]))))] - - [ldc/integer //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])] - [ldc/long //constant.Long //constant/pool.long _.ldc2-w/long - (<|) - ([+0 _.lconst-0] - [+1 _.lconst-1])] - [ldc/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])] - [ldc/double //constant.Double //constant/pool.double _.ldc2-w/double - (<|) - ([+0.0 _.fconst-0] - [+1.0 _.fconst-1])] - ) - -(template [ <0> <1> <2> <3>] - [(def: #export ( local) - (-> (Instruction Any)) - (case (//unsigned.nat local) - 0 (..opcode <0> []) - 1 (..opcode <1> []) - 2 (..opcode <2> []) - 3 (..opcode <3> []) - _ (..opcode [local])))] - - [iload _.iload Local _.iload-0 _.iload-1 _.iload-2 _.iload-3] - [lload _.lload Local _.lload-0 _.lload-1 _.lload-2 _.lload-3] - [fload _.fload Local _.fload-0 _.fload-1 _.fload-2 _.fload-3] - [dload _.dload Local _.dload-0 _.dload-1 _.dload-2 _.dload-3] - [aload _.aload Local _.aload-0 _.aload-1 _.aload-2 _.aload-3] - - [istore _.istore Local _.istore-0 _.istore-1 _.istore-2 _.istore-3] - [lstore _.lstore Local _.lstore-0 _.lstore-1 _.lstore-2 _.lstore-3] - [fstore _.fstore Local _.fstore-0 _.fstore-1 _.fstore-2 _.fstore-3] - [dstore _.dstore Local _.dstore-0 _.dstore-1 _.dstore-2 _.dstore-3] - [astore _.astore Local _.astore-0 _.astore-1 _.astore-2 _.astore-3] - ) - -(template [ ] - [(def: #export - (-> (Instruction Any)) - (..opcode ))] - - [ret _.ret Local] - [newarray _.newarray Primitive-Array-Type] - [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" (%.nat @from)] - ["Target" (|> jump //signed.int %.int)])) - -(def: (jump @from @to) - (-> Address Address (Either Jump Big-Jump)) - (let [jump (.int (n.- @to @from)) - big? (n.> (//unsigned.nat //unsigned.max-u2) - (.nat (i.* (if (i.>= +0 jump) - +1 - -1) - jump)))] - (if big? - (#.Right (//signed.s4 jump)) - (#.Left (//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 [ ] - [(def: #export ( label) - (-> Label (Instruction Any)) - (let [[estimator bytecode] ] - (function (_ [pool tracker]) - (let [@from (get@ #program-counter tracker)] - [[pool (update@ #program-counter (count estimator) tracker)] - [(function (_ resolver) - (do try.monad - [@to (..resolve-label label resolver)] - (case (jump @from @to) - (#.Left jump) - (#try.Success [..no-exceptions (bytecode jump)]) - - (#.Right jump) - (exception.throw ..cannot-do-a-big-jump [label @from jump])))) - []]]))))] - - [ifeq _.ifeq] - [ifne _.ifne] - [iflt _.iflt] - [ifge _.ifge] - [ifgt _.ifgt] - [ifle _.ifle] - - [if-icmpeq _.if-icmpeq] - [if-icmpne _.if-icmpne] - [if-icmplt _.if-icmplt] - [if-icmpge _.if-icmpge] - [if-icmpgt _.if-icmpgt] - [if-icmple _.if-icmple] - - [if-acmpeq _.if-acmpeq] - [if-acmpne _.if-acmpne] - - [ifnull _.ifnull] - [ifnonnull _.ifnonnull] - ) - -(template [ ] - [(def: #export ( label) - (-> Label (Instruction Any)) - (let [[normal-estimator normal-bytecode] - ## TODO: No more polymorphic GOTO and JSR. - ## [wide-estimator wide-bytecode] - ] - (function (_ [pool tracker]) - (let [@from (get@ #program-counter tracker)] - [[pool (update@ #program-counter (count normal-estimator) tracker)] - [(function (_ resolver) - (case (dictionary.get label resolver) - (#.Some @to) - (case (jump @from @to) - (#.Left jump) - (#try.Success [..no-exceptions (normal-bytecode jump)]) - - (#.Right jump) - (undefined) - ## TODO: No more polymorphic GOTO and JSR. - ## (#try.Success [..no-exceptions ( jump)]) - ) - - #.None - (exception.throw ..unknown-label [label]))) - []]]))))] - - [goto _.goto _.goto-w] - [jsr _.jsr _.jsr-w] - ) - -(def: (big-jump jump) - (-> (Either Jump Big-Jump) Big-Jump) - (case jump - (#.Left small) - (/jump.lift small) - - (#.Right big) - big)) - -(exception: #export invalid-tableswitch) - -(def: #export (tableswitch minimum default cases) - (-> S4 Label (List Label) (Instruction Any)) - (let [[estimator bytecode] _.tableswitch] - (function (_ [pool tracker]) - (let [@from (get@ #program-counter tracker)] - [[pool (update@ #program-counter (count (estimator (list.size cases))) 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) - #let [>default (big-jump (jump @from @default)) - >cases (list@map (|>> (jump @from) big-jump) - @cases)]] - (wrap (bytecode minimum >default >cases))) - (#.Some bytecode) - (#try.Success [..no-exceptions bytecode]) - - #.None - (exception.throw ..invalid-tableswitch [])))) - []]])))) - -(exception: #export invalid-lookupswitch) - -(def: #export (lookupswitch default cases) - (-> Label (List [S4 Label]) (Instruction Any)) - (let [[estimator bytecode] _.lookupswitch] - (function (_ [pool tracker]) - (let [@from (get@ #program-counter tracker)] - [[pool (update@ #program-counter (count (estimator (list.size cases))) 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) - #let [>default (big-jump (jump @from @default)) - >cases (|> @cases - (list@map (|>> (jump @from) big-jump)) - (list.zip2 (list@map product.left cases)))]] - (wrap (bytecode >default >cases))) - (#.Some bytecode) - (#try.Success [..no-exceptions bytecode]) - - #.None - (exception.throw ..invalid-lookupswitch [])))) - []]])))) - -(template [ ] - [(def: #export ( class) - (-> (Type ) (Instruction Any)) - (do ..monad - ## TODO: Make sure it"s impossible to have indexes greater than U2. - [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] - (..opcode [index])))] - - [new Class _.new] - [anewarray Object _.anewarray] - [checkcast Object _.checkcast] - [instanceof Object _.instanceof] - ) - -(def: #export (iinc register increase) - (-> Local U1 (Instruction Any)) - (..opcode _.iinc [register increase])) - -(def: #export (multianewarray class count) - (-> (Type Class) U1 (Instruction Any)) - (do ..monad - [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] - (..opcode _.multianewarray [index count]))) - -(def: (type-size type) - (-> (Type Return) U1) - (//unsigned.u1 - (cond (is? type.void type) - 0 - - (or (is? type.long type) - (is? type.double type)) - 2 - - ## else - 1))) - -(template [ ] - [(def: #export ( class method type) - (-> (Type Class) Text (Type Method) (Instruction 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)})] - (..opcode - [index - (|> inputs - (list@map ..type-size) - (list@fold //unsigned.u1/+ (//unsigned.u1 (if 0 1)))) - (..type-size output)]))))] - - [#1 invokestatic _.invokestatic] - [#0 invokevirtual _.invokevirtual] - [#0 invokespecial _.invokespecial] - [#0 invokeinterface _.invokeinterface] - ) - -(template [ <1> <2>] - [(def: #export ( class field type) - (-> (Type Class) Text (Type Value) (Instruction Any)) - (do ..monad - [index (<| ..lift - (//constant/pool.field (..reflection class)) - {#//constant/pool.name field - #//constant/pool.descriptor (type.descriptor type)})] - (cond (is? type.long type) - (..opcode <2> [index]) - - (is? type.double type) - (..opcode <2> [index]) - - ## else - (..opcode <1> [index]))))] - - [getstatic _.getstatic/1 _.getstatic/2] - [putstatic _.putstatic/1 _.putstatic/2] - [getfield _.getfield/1 _.getfield/2] - [putfield _.putfield/1 _.putfield/2] - ) - -(exception: #export (invalid-range-for-try {start Address} {end Address}) - (exception.report - ["Start" (%.nat start)] - ["End" (%.nat end)])) - -(def: #export (try @start @end @handler catch) - (-> Label Label Label (Type Class) (Instruction Any)) - (do ..monad - [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))] - (function (_ [pool tracker]) - [[pool tracker] - [(function (_ resolver) - (do try.monad - [@@start (..resolve-label @start resolver) - @@end (..resolve-label @end resolver) - _ (if (n.< @@end @@start) - (wrap []) - (exception.throw ..invalid-range-for-try [@@start @@end])) - @@handler (..resolve-label @handler resolver)] - (wrap [(row.row {#//exception.start (/address.address (//unsigned.u2 @@start)) - #//exception.end (/address.address (//unsigned.u2 @@end)) - #//exception.handler (/address.address (//unsigned.u2 @@handler)) - #//exception.catch @catch}) - ..no-bytecode]))) - []]]))) - -(def: #export (compose pre post) - (All [pre post] - (-> (Instruction pre) (Instruction post) (Instruction post))) - (do ..monad - [_ pre] - post)) diff --git a/stdlib/source/lux/target/jvm/instruction/bytecode.lux b/stdlib/source/lux/target/jvm/instruction/bytecode.lux deleted file mode 100644 index 17f57ea1f..000000000 --- a/stdlib/source/lux/target/jvm/instruction/bytecode.lux +++ /dev/null @@ -1,660 +0,0 @@ -(.module: - [lux (#- Code) - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [parser - [binary (#+ Offset)]]] - [data - ["." product] - ["." binary] - [number (#+ hex) - ["n" nat]] - [text - ["%" format (#+ format)]] - [format - [".F" binary (#+ Mutation Specification)]] - [collection - ["." list]]] - [macro - ["." template]] - [type - abstract]] - ["." // #_ - ["#." resources (#+ Resources)] - ["/" condition (#+ Environment Condition Local) ("#@." monoid)] - ["#." jump (#+ Jump Big-Jump)] - ["/#" // #_ - ["#." index (#+ Index)] - ["#." constant (#+ Class Reference)] - [encoding - ["#." unsigned (#+ U1 U2 U4)] - ["#." signed (#+ S2 S4)]] - [type - [category (#+ Value Method)]]]]) - -(type: #export Size Nat) - -(type: #export Estimator - (-> Offset Size)) - -(type: #export Bytecode - (-> [Environment Specification] - (Try [Environment Specification]))) - -(def: no-bytecode Bytecode (|>> #try.Success)) - -(def: #export run - (-> Bytecode (Try [Environment Specification])) - (function.apply [/.start binaryF.no-op])) - -(type: Opcode - (-> Specification Specification)) - -(def: (bytecode condition transform) - (-> Condition Opcode Bytecode) - (function (_ [environment specification]) - (do try.monad - [environment' (condition environment)] - (wrap [environment' - (transform specification)])))) - -(type: Code Nat) - -(def: code-size Size 1) -(def: big-jump-size Size 4) -(def: integer-size Size 4) - -(def: (fixed size) - (-> Size Estimator) - (function (_ offset) - size)) - -(def: (nullary' code) - (-> Code Mutation) - (function (_ [offset binary]) - [(n.+ ..code-size offset) - (try.assume - (binary.write/8 offset code binary))])) - -(def: nullary - [Estimator - (-> Code Opcode)] - [(..fixed ..code-size) - (function (_ code [size mutation]) - [(n.+ ..code-size size) - (|>> mutation ((nullary' code)))])]) - -(def: size/1 ($_ n.+ ..code-size 1)) -(def: size/2 ($_ n.+ ..code-size 2)) -(def: size/4 ($_ n.+ ..code-size 4)) - -(template [ ] - [(with-expansions [ (template.identifier [ "'"])] - (def: ( code input0) - (-> Code Mutation) - (function (_ [offset binary]) - [(n.+ offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset code binary)] - ( (n.+ 1 offset) ( input0) binary)))])) - - (def: - [Estimator - (-> Code Opcode)] - [(..fixed ) - (function (_ code input0 [size mutation]) - [(n.+ size) - (|>> mutation (( code input0)))])]))] - - [..size/1 unary/1 U1 binary.write/8 ///unsigned.nat] - [..size/2 unary/2 U2 binary.write/16 ///unsigned.nat] - [..size/2 jump/2 S2 binary.write/16 ///signed.int] - [..size/4 jump/4 S4 binary.write/32 ///signed.int] - ) - -(def: size/11 ($_ n.+ ..code-size 1 1)) - -(def: (binary/11' code input0 input1) - (-> Code U1 U1 Mutation) - (function (_ [offset binary]) - [(n.+ ..size/11 offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/8 (n.+ 1 offset) (///unsigned.nat input0) binary)] - (binary.write/8 (n.+ 2 offset) (///unsigned.nat input1) binary)))])) - -(def: binary/11 - [Estimator - (-> Code U1 U1 Opcode)] - [(..fixed ..size/11) - (function (_ code input0 input1 [size mutation]) - [(n.+ ..size/11 size) - (|>> mutation ((binary/11' code input0 input1)))])]) - -(def: size/21 ($_ n.+ ..code-size 2 1)) - -(def: (binary/21' code input0 input1) - (-> Code U2 U1 Mutation) - (function (_ [offset binary]) - [(n.+ ..size/21 offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/16 (n.+ 1 offset) (///unsigned.nat input0) binary)] - (binary.write/8 (n.+ 3 offset) (///unsigned.nat input1) binary)))])) - -(def: binary/21 - [Estimator - (-> Code U2 U1 Opcode)] - [(..fixed ..size/21) - (function (_ code input0 input1 [size mutation]) - [(n.+ ..size/21 size) - (|>> mutation ((binary/21' code input0 input1)))])]) - -(def: size/211 ($_ n.+ ..code-size 2 1 1)) - -(def: (trinary/211' code input0 input1 input2) - (-> Code U2 U1 U1 Mutation) - (function (_ [offset binary]) - [(n.+ ..size/211 offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/16 (n.+ 1 offset) (///unsigned.nat input0) binary) - _ (binary.write/8 (n.+ 3 offset) (///unsigned.nat input1) binary)] - (binary.write/8 (n.+ 4 offset) (///unsigned.nat input2) binary)))])) - -(def: trinary/211 - [Estimator - (-> Code U2 U1 U1 Opcode)] - [(..fixed ..size/211) - (function (_ code input0 input1 input2 [size mutation]) - [(n.+ ..size/211 size) - (|>> mutation ((trinary/211' code input0 input1 input2)))])]) - -(abstract: #export Primitive-Array-Type - {} - - U1 - - (def: code - (-> Primitive-Array-Type U1) - (|>> :representation)) - - (template [ ] - [(def: #export (|> ///unsigned.u1 :abstraction))] - - [04 t-boolean] - [05 t-char] - [06 t-float] - [07 t-double] - [08 t-byte] - [09 t-short] - [10 t-int] - [11 t-long] - )) - -## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 -(with-expansions [ (template [ ] - [[ [] [] 0 []]] - - ["01" aconst-null 1] - - ["02" iconst-m1 1] - ["03" iconst-0 1] - ["04" iconst-1 1] - ["05" iconst-2 1] - ["06" iconst-3 1] - ["07" iconst-4 1] - ["08" iconst-5 1] - - ["09" lconst-0 2] - ["0A" lconst-1 2] - - ["0B" fconst-0 1] - ["0C" fconst-1 1] - ["0D" fconst-2 1] - - ["0E" dconst-0 2] - ["0F" dconst-1 2]) - (template [ ] - [[ [[local Local]] [local] 0 [[local]]]] - - ["15" iload 1] - ["16" lload 2] - ["17" fload 1] - ["18" dload 2] - ["19" aload 1]) - (template [ ] - [[ [] [] 0 [[(///unsigned.u1 )]]]] - - ["1A" iload-0 1 0] - ["1B" iload-1 1 1] - ["1C" iload-2 1 2] - ["1D" iload-3 1 3] - - ["1E" lload-0 2 1] - ["1F" lload-1 2 2] - ["20" lload-2 2 3] - ["21" lload-3 2 4] - - ["22" fload-0 1 0] - ["23" fload-1 1 1] - ["24" fload-2 1 2] - ["25" fload-3 1 3] - - ["26" dload-0 2 1] - ["27" dload-1 2 2] - ["28" dload-2 2 3] - ["29" dload-3 2 4] - - ["2A" aload-0 1 0] - ["2B" aload-1 1 1] - ["2C" aload-2 1 2] - ["2D" aload-3 1 3]) - (template [ ] - [[ [[local Local]] [local] 0 [[local]]]] - - ["36" istore 1] - ["37" lstore 2] - ["38" fstore 1] - ["39" dstore 2] - ["3A" astore 1]) - (template [ ] - [[ [] [] 0 [[(///unsigned.u1 )]]]] - - ["3B" istore-0 1 0] - ["3C" istore-1 1 1] - ["3D" istore-2 1 2] - ["3E" istore-3 1 3] - - ["3F" lstore-0 2 1] - ["40" lstore-1 2 2] - ["41" lstore-2 2 3] - ["42" lstore-3 2 4] - - ["43" fstore-0 1 0] - ["44" fstore-1 1 1] - ["45" fstore-2 1 2] - ["46" fstore-3 1 3] - - ["47" dstore-0 2 1] - ["48" dstore-1 2 2] - ["49" dstore-2 2 3] - ["4A" dstore-3 2 4] - - ["4B" astore-0 1 0] - ["4C" astore-1 1 1] - ["4D" astore-2 1 2] - ["4E" astore-3 1 3]) - (template [ ] - [[ [] [] 2 []]] - - ["2E" iaload 1] - ["2F" laload 2] - ["30" faload 1] - ["31" daload 2] - ["32" aaload 1] - ["33" baload 1] - ["34" caload 1] - ["35" saload 1]) - (template [ ] - [[ [] [] 0 []]] - - ["4f" iastore 3] - ["50" lastore 4] - ["51" fastore 3] - ["52" dastore 4] - ["53" aastore 3] - ["54" bastore 3] - ["55" castore 3] - ["56" sastore 3]) - (template [ ] - [[ [] [] []]] - - ["60" iadd 2 1] - ["64" isub 2 1] - ["68" imul 2 1] - ["6c" idiv 2 1] - ["70" irem 2 1] - ["74" ineg 1 1] - ["78" ishl 2 1] - ["7a" ishr 2 1] - ["7c" iushr 2 1] - ["7e" iand 2 1] - ["80" ior 2 1] - ["82" ixor 2 1] - - ["61" ladd 4 2] - ["65" lsub 4 2] - ["69" lmul 4 2] - ["6D" ldiv 4 2] - ["71" lrem 4 2] - ["75" lneg 2 2] - ["7F" land 4 2] - ["81" lor 4 2] - ["83" lxor 4 2] - - ["62" fadd 2 1] - ["66" fsub 2 1] - ["6A" fmul 2 1] - ["6E" fdiv 2 1] - ["72" frem 2 1] - ["76" fneg 1 1] - - ["63" dadd 4 2] - ["67" dsub 4 2] - ["6B" dmul 4 2] - ["6F" ddiv 4 2] - ["73" drem 4 2] - ["77" dneg 2 2]) - (template [ ] - [[ [] [] []]] - - ["88" l2i 2 1] - ["89" l2f 2 1] - ["8A" l2d 2 2] - - ["8B" f2i 1 1] - ["8C" f2l 1 2] - ["8D" f2d 1 2] - - ["8E" d2i 2 1] - ["8F" d2l 2 2] - ["90" d2f 2 1] - - ["85" i2l 1 2] - ["86" i2f 1 1] - ["87" i2d 1 2] - ["91" i2b 1 1] - ["92" i2c 1 1] - ["93" i2s 1 1]) - (template [ ] - [[ [] [] 1 []]] - - ["94" lcmp 4] - - ["95" fcmpl 2] - ["96" fcmpg 2] - - ["97" dcmpl 4] - ["98" dcmpg 4]) - (template [ ] - [[ [] [] 0 []]] - - ["AC" ireturn 1] - ["AD" lreturn 2] - ["AE" freturn 1] - ["AF" dreturn 2] - ["B0" areturn 1] - ["B1" return 0] - ) - (template [ ] - [[ [[jump Jump]] [jump] []]] - - ["99" ifeq 2 0] - ["9A" ifne 2 0] - ["9B" iflt 2 0] - ["9C" ifge 2 0] - ["9D" ifgt 2 0] - ["9E" ifle 2 0] - - ["9F" if-icmpeq 2 0] - ["A0" if-icmpne 2 0] - ["A1" if-icmplt 2 0] - ["A2" if-icmpge 2 0] - ["A3" if-icmpgt 2 0] - ["A4" if-icmple 2 0] - - ["A5" if-acmpeq 2 0] - ["A6" if-acmpne 2 0] - - ["A7" goto 0 0] - ["A8" jsr 0 1] - - ["C6" ifnull 1 0] - ["C7" ifnonnull 1 0]) - (template [ ] - [[ [[index (Index (Reference Value))]] [(///index.number index)] []]] - - ["B2" getstatic/1 0 1] ["B2" getstatic/2 0 2] - ["B3" putstatic/1 1 1] ["B3" putstatic/2 1 2] - ["B4" getfield/1 1 1] ["B4" getfield/2 1 2] - ["B5" putfield/1 2 1] ["B5" putfield/2 2 2])] - (template [ ] - [(with-expansions [' (template.splice )] - (template [ ] - [(with-expansions [' (template.splice ) - (template [ ] - [] - - ') - (template [ ] - [] - - ') - ' (template.splice )] - (def: #export - [Estimator - (-> [] Bytecode)] - (let [[estimator '] ] - [estimator - (function (_ []) - (..bytecode - (`` ($_ /@compose - (/.consumes ) - (/.produces ) - (~~ (template [] - [(/.has-local )] - - ')))) - (`` (' (hex ) (~~ (template.splice ))))))])))] - - ' - ))] - - [..nullary - [["00" nop [] [] 0 0 []] - - ["57" pop [] [] 1 0 []] - ["58" pop2 [] [] 2 0 []] - ["59" dup [] [] 1 2 []] - ["5A" dup-x1 [] [] 2 3 []] - ["5B" dup-x2 [] [] 3 4 []] - ["5C" dup2 [] [] 2 4 []] - ["5D" dup2-x1 [] [] 3 5 []] - ["5E" dup2-x2 [] [] 4 6 []] - ["5F" swap [] [] 2 2 []] - - - - - - ["79" lshl [] [] 3 2 []] - ["7B" lshr [] [] 3 2 []] - ["7D" lushr [] [] 3 2 []] - - - - ["BE" arraylength [] [] 1 1 []] - ["BF" athrow [] [] 1 0 []] - ["C2" monitorenter [] [] 1 0 []] - ["C3" monitorexit [] [] 1 0 []]]] - - [..unary/1 - [["10" bipush [[byte U1]] [byte] 0 1 []] - ["12" ldc [[index U1]] [index] 0 1 []] - - - ["A9" ret [[local Local]] [local] 0 0 [[local]]] - ["BC" newarray [[type Primitive-Array-Type]] [(..code type)] 1 1 []]]] - - [..unary/2 - [["11" sipush [[short U2]] [short] 0 1 []] - ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []] - ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []] - ["13" ldc-w/string [[index (Index ///constant.String)]] [(///index.number index)] 0 1 []] - ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 2 []] - ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 2 []] - - ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []] - ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []] - ["C0" checkcast [[index (Index Class)]] [(///index.number index)] 1 1 []] - ["C1" instanceof [[index (Index Class)]] [(///index.number index)] 1 1 []] - ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []] - ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []] - ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]]] - - [..jump/2 - []] - - [..jump/4 - [["C8" goto-w [[jump Big-Jump]] [jump] 0 0 []] - ["C9" jsr-w [[jump Big-Jump]] [jump] 0 1 []]]] - - [..binary/11 - [["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]] - - [..binary/21 - [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.number index) count] (///unsigned.nat count) 1 []]]] - - [..trinary/211 - [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index) count (///unsigned.u1 0)] (///unsigned.nat count) (///unsigned.nat output-count) []]]] - )) - -(def: (switch-padding offset) - (n.% 4 - (n.- (n.% 4 (n.+ ..code-size offset)) - 4))) - -(def: #export tableswitch - [(-> Nat Estimator) - (-> S4 Big-Jump (List Big-Jump) Bytecode)] - (let [estimator (: (-> Nat Estimator) - (function (_ amount-of-cases offset) - ($_ n.+ - ..code-size - (switch-padding offset) - ..big-jump-size - ..integer-size - ..integer-size - (n.* amount-of-cases ..big-jump-size))))] - [estimator - (function (_ minimum default cases) - (let [amount-of-cases (list.size cases) - maximum (|> amount-of-cases .int ///signed.s4 (///signed.s4/+ minimum)) - estimator (estimator amount-of-cases) - opcode (: Opcode - (function (_ [size mutation]) - (let [padding (switch-padding size) - tableswitch-size (estimator size) - tableswitch-mutation (: Mutation - (function (_ [offset binary]) - [(n.+ tableswitch-size offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset (hex "AA") binary) - #let [offset (n.+ ..code-size offset)] - _ (case padding - 3 (do @ - [_ (binary.write/8 offset 0 binary)] - (binary.write/16 (inc offset) 0 binary)) - 2 (binary.write/16 offset 0 binary) - 1 (binary.write/8 offset 0 binary) - _ (wrap binary)) - #let [offset (n.+ padding offset)] - _ (binary.write/32 offset (///signed.int default) binary) - #let [offset (n.+ ..big-jump-size offset)] - _ (binary.write/32 offset (///signed.int minimum) binary) - #let [offset (n.+ ..integer-size offset)] - _ (binary.write/32 offset (///signed.int maximum) binary)] - (loop [offset (n.+ ..integer-size offset) - cases cases] - (case cases - #.Nil - (wrap binary) - - (#.Cons head tail) - (do @ - [_ (binary.write/32 offset (///signed.int head) binary)] - (recur (n.+ ..big-jump-size offset) - tail))))))]))] - [(n.+ tableswitch-size - size) - (|>> mutation tableswitch-mutation)])))] - (..bytecode (/.consumes 1) - opcode)))])) - -(def: #export lookupswitch - [(-> Nat Estimator) - (-> Big-Jump (List [S4 Big-Jump]) Bytecode)] - (let [case-size (n.+ ..integer-size ..big-jump-size) - estimator (: (-> Nat Estimator) - (function (_ amount-of-cases offset) - ($_ n.+ - ..code-size - (switch-padding offset) - ..big-jump-size - ..integer-size - (n.* amount-of-cases case-size))))] - [estimator - (function (_ default cases) - (let [amount-of-cases (list.size cases) - estimator (estimator amount-of-cases) - opcode (: Opcode - (function (_ [size mutation]) - (let [padding (switch-padding size) - lookupswitch-size (estimator size) - lookupswitch-mutation (: Mutation - (function (_ [offset binary]) - [(n.+ lookupswitch-size offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset (hex "AB") binary) - #let [offset (n.+ ..code-size offset)] - _ (case padding - 3 (do @ - [_ (binary.write/8 offset 0 binary)] - (binary.write/16 (inc offset) 0 binary)) - 2 (binary.write/16 offset 0 binary) - 1 (binary.write/8 offset 0 binary) - _ (wrap binary)) - #let [offset (n.+ padding offset)] - _ (binary.write/32 offset (///signed.int default) binary) - #let [offset (n.+ ..big-jump-size offset)] - _ (binary.write/32 offset amount-of-cases binary)] - (loop [offset (n.+ ..integer-size offset) - cases cases] - (case cases - #.Nil - (wrap binary) - - (#.Cons [value jump] tail) - (do @ - [_ (binary.write/32 offset (///signed.int value) binary) - _ (binary.write/32 (n.+ ..integer-size offset) (///signed.int jump) binary)] - (recur (n.+ case-size offset) - tail))))))]))] - [(n.+ lookupswitch-size - size) - (|>> mutation lookupswitch-mutation)])))] - (..bytecode (/.consumes 1) - opcode)))])) - -(structure: #export monoid - (Monoid Bytecode) - - (def: identity ..no-bytecode) - - (def: (compose left right) - (function (_ input) - (do try.monad - [temp (left input)] - (right temp))))) diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux index 060ad1bc1..cd62830ea 100644 --- a/stdlib/source/lux/target/jvm/method.lux +++ b/stdlib/source/lux/target/jvm/method.lux @@ -16,14 +16,14 @@ [type [abstract (#+)]]] ["." // #_ - ["#." modifier (#+ Modifier modifiers:)] + ["#." modifier (#+ Modifier modifiers:) ("#@." monoid)] ["#." index (#+ Index)] ["#." attribute (#+ Attribute) ["#/." code]] ["#." constant (#+ UTF8) ["#/." pool (#+ Pool Resource)]] ["#." bytecode (#+ Bytecode) - ["#/." environment] + ["#/." environment (#+ Environment)] ["#/." instruction]] ["#." type (#+ Type) ["#/." category] @@ -51,22 +51,39 @@ ) (def: #export (method modifier name type attributes code) - (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Bytecode Any) + (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any)) (Resource Method)) (do //constant/pool.monad [@name (//constant/pool.utf8 name) @descriptor (//constant/pool.descriptor (//type.descriptor type)) - attributes (monad.seq @ attributes) - [environment exceptions instruction output] (//bytecode.resolve code) - #let [bytecode (|> instruction //bytecode/instruction.run format.instance)] - @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment) - #//attribute/code.code bytecode - #//attribute/code.exception-table exceptions - #//attribute/code.attributes (row.row)})] + attributes (|> attributes + (monad.seq @) + (:: @ map row.from-list)) + attributes (case code + (#.Some code) + (do @ + [environment (case (if (//modifier.has? static modifier) + (//bytecode/environment.static type) + (//bytecode/environment.virtual type)) + (#try.Success environment) + (wrap environment) + + (#try.Failure error) + (function (_ _) (#try.Failure error))) + [environment exceptions instruction output] (//bytecode.resolve environment code) + #let [bytecode (|> instruction //bytecode/instruction.run format.instance)] + @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment) + #//attribute/code.code bytecode + #//attribute/code.exception-table exceptions + #//attribute/code.attributes (row.row)})] + (wrap (row.add @code attributes))) + + #.None + (wrap attributes))] (wrap {#modifier modifier #name @name #descriptor @descriptor - #attributes (|> attributes row.from-list (row.add @code))}))) + #attributes attributes}))) (def: #export equivalence (Equivalence Method) diff --git a/stdlib/source/lux/target/jvm/modifier.lux b/stdlib/source/lux/target/jvm/modifier.lux index 3eafb170a..71e5c61bc 100644 --- a/stdlib/source/lux/target/jvm/modifier.lux +++ b/stdlib/source/lux/target/jvm/modifier.lux @@ -27,6 +27,17 @@ {} //unsigned.U2 + (def: #export code + (-> (Modifier Any) //unsigned.U2) + (|>> :representation)) + + (structure: #export equivalence + (All [of] (Equivalence (Modifier of))) + (def: (= reference sample) + (:: //unsigned.equivalence = + (:representation reference) + (:representation sample)))) + (template: (!wrap value) (|> value //unsigned.u2 @@ -38,20 +49,12 @@ :representation //unsigned.value)) - (def: #export code - (-> (Modifier Any) //unsigned.U2) - (|>> :representation)) - - (def: modifier - (-> Nat Modifier) - (|>> !wrap)) - - (structure: #export equivalence - (All [of] (Equivalence (Modifier of))) - (def: (= reference sample) - (:: //unsigned.equivalence = - (:representation reference) - (:representation sample)))) + (def: #export (has? sub super) + (All [of] (-> (Modifier of) (Modifier of) Bit)) + (let [sub (!unwrap sub)] + (|> (!unwrap super) + (i64.and sub) + (:: i64.equivalence = sub)))) (structure: #export monoid (All [of] (Monoid (Modifier of))) @@ -69,6 +72,10 @@ (def: #export writer (All [of] (Writer (Modifier of))) (|>> :representation //unsigned.writer/2)) + + (def: modifier + (-> Nat Modifier) + (|>> !wrap)) ) (syntax: #export (modifiers: ofT {options (<>.many .any)}) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index e6d48aa21..2617eeacf 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -42,12 +42,12 @@ ["#." version] ["#." modifier ("#@." monoid)] ["#." field] - ["#." method] + ["#." method (#+ Method)] ["#." class] ["#." attribute ["#/." code]] ["#." constant - ["#/." pool]] + ["#/." pool (#+ Resource)]] [encoding ["#." name] ["#." signed] @@ -58,7 +58,7 @@ [limit [registry (#+ Register)]]]] ["#." type (#+ Type) - ["." category (#+ Value Object)]]]}) + ["." category (#+ Value Object Class)]]]}) ## (def: (write-class! name bytecode) ## (-> Text Binary (IO Text)) @@ -134,9 +134,9 @@ method-name (/type.method [(list) ..$Object (list)]) (list) - (do /.monad - [_ bytecode] - /.areturn))) + (#.Some (do /.monad + [_ bytecode] + /.areturn)))) (row.row)) #let [bytecode (format.run /class.writer class) loader (/loader.memory (/loader.new-library []))] @@ -742,11 +742,11 @@ part1 ..$Long::random #let [expected (i.+ part0 part1) $Self (/type.class class-name (list)) - class-field "instances" - object-field "value" + class-field "class_field" + object-field "object_field" constructor "" constructor::type (/type.method [(list /type.long) /type.void (list)]) - static-method "procedure" + static-method "static_method" bytecode (|> (/class.class /version.v6_0 /class.public (/name.internal class-name) (/name.internal "java.lang.Object") @@ -757,31 +757,31 @@ constructor constructor::type (list) - (do /.monad - [_ /.aload-0 - _ (/.invokespecial ..$Object "" (/type.method [(list) /type.void (list)])) - _ (..$Long::literal part0) - _ (/.putstatic $Self class-field /type.long) - _ /.aload-0 - _ /.lload-1 - _ (/.putfield $Self object-field /type.long)] - /.return)) + (#.Some (do /.monad + [_ /.aload-0 + _ (/.invokespecial ..$Object constructor (/type.method [(list) /type.void (list)])) + _ (..$Long::literal part0) + _ (/.putstatic $Self class-field /type.long) + _ /.aload-0 + _ /.lload-1 + _ (/.putfield $Self object-field /type.long)] + /.return))) (/method.method ($_ /modifier@compose /method.public /method.static) static-method (/type.method [(list) ..$Long (list)]) (list) - (do /.monad - [_ (/.new $Self) - _ /.dup - _ (..$Long::literal part1) - _ (/.invokespecial $Self "" constructor::type) - _ (/.getfield $Self object-field /type.long) - _ (/.getstatic $Self class-field /type.long) - _ /.ladd - _ ..$Long::wrap] - /.areturn))) + (#.Some (do /.monad + [_ (/.new $Self) + _ /.dup + _ (..$Long::literal part1) + _ (/.invokespecial $Self constructor constructor::type) + _ (/.getfield $Self object-field /type.long) + _ (/.getstatic $Self class-field /type.long) + _ /.ladd + _ ..$Long::wrap] + /.areturn)))) (row.row)) try.assume (format.run /class.writer)) @@ -1204,23 +1204,23 @@ primitive-method-name primitive-method-type (list) - (do /.monad - [_ ((get@ #literal primitive) expected)] - return)) + (#.Some (do /.monad + [_ ((get@ #literal primitive) expected)] + return))) (/method.method ..method-modifier object-method-name (/type.method [(list) (get@ #boxed primitive) (list)]) (list) - (do /.monad - [_ (/.invokestatic $Self primitive-method-name primitive-method-type) - _ (case substitute - #.None - (wrap []) + (#.Some (do /.monad + [_ (/.invokestatic $Self primitive-method-name primitive-method-type) + _ (case substitute + #.None + (wrap []) - (#.Some substitute) - (substitute expected)) - _ (get@ #wrap primitive)] - /.areturn))) + (#.Some substitute) + (substitute expected)) + _ (get@ #wrap primitive)] + /.areturn)))) (row.row)) #let [bytecode (format.run /class.writer class) loader (/loader.memory (/loader.new-library []))] @@ -1441,9 +1441,152 @@ ..code) )) +(def: inheritance + Test + (do random.monad + [abstract-class ..class-name + interface-class (|> ..class-name + (random.filter (|>> (text@= abstract-class) not))) + concrete-class (|> ..class-name + (random.filter (function (_ class) + (not (or (text@= abstract-class class) + (text@= interface-class class)))))) + part0 ..$Long::random + part1 ..$Long::random + part2 ..$Long::random + fake-part2 ..$Long::random + part3 ..$Long::random + part4 ..$Long::random + #let [expected ($_ i.+ + part0 + part1 + part2 + part3 + part4 + ) + $Concrete (/type.class concrete-class (list)) + $Abstract (/type.class abstract-class (list)) + $Interface (/type.class interface-class (list)) + + constructor::type (/type.method [(list) /type.void (list)]) + method::type (/type.method [(list) /type.long (list)]) + + inherited-method "inherited_method" + overriden-method "overriden_method" + abstract-method "abstract_method" + interface-method "interface_method" + virtual-method "virtual_method" + static-method "static_method" + + method (: (-> Text java/lang/Long (Resource Method)) + (function (_ name value) + (/method.method /method.public + name + method::type + (list) + (#.Some (do /.monad + [_ (..$Long::literal value)] + /.lreturn))))) + + interface-bytecode (|> (/class.class /version.v6_0 ($_ /modifier@compose /class.public /class.abstract /class.interface) + (/name.internal interface-class) + (/name.internal "java.lang.Object") + (list) + (list) + (list (/method.method ($_ /modifier@compose /method.public /method.abstract) + interface-method method::type (list) #.None)) + (row.row)) + try.assume + (format.run /class.writer)) + abstract-bytecode (|> (/class.class /version.v6_0 ($_ /modifier@compose /class.public /class.abstract) + (/name.internal abstract-class) + (/name.internal "java.lang.Object") + (list) + (list) + (list (/method.method /method.public + "" + constructor::type + (list) + (#.Some (do /.monad + [_ /.aload-0 + _ (/.invokespecial ..$Object "" constructor::type)] + /.return))) + (method inherited-method part0) + (method overriden-method fake-part2) + (/method.method ($_ /modifier@compose /method.public /method.abstract) + abstract-method method::type (list) #.None)) + (row.row)) + try.assume + (format.run /class.writer)) + invoke (: (-> (Type Class) Text (Bytecode Any)) + (function (_ class method) + (do /.monad + [_ /.aload-0] + (/.invokevirtual class method method::type)))) + concrete-bytecode (|> (/class.class /version.v6_0 /class.public + (/name.internal concrete-class) + (/name.internal abstract-class) + (list (/name.internal interface-class)) + (list) + (list (/method.method /method.public + "" + constructor::type + (list) + (#.Some (do /.monad + [_ /.aload-0 + _ (/.invokespecial $Abstract "" constructor::type)] + /.return))) + (method virtual-method part1) + (method overriden-method part2) + (method abstract-method part3) + (method interface-method part4) + (/method.method ($_ /modifier@compose + /method.public + /method.static) + static-method + (/type.method [(list) ..$Long (list)]) + (list) + (#.Some (do /.monad + [_ (/.new $Concrete) + _ /.dup + _ (/.invokespecial $Concrete "" constructor::type) + _ /.astore-0 + _ (invoke $Abstract inherited-method) + _ (invoke $Concrete virtual-method) + _ /.ladd + _ (invoke $Abstract overriden-method) + _ /.ladd + _ /.aload-0 _ (/.invokeinterface $Interface interface-method method::type) + _ /.ladd + _ (invoke $Abstract abstract-method) + _ /.ladd + _ ..$Long::wrap] + /.areturn)))) + (row.row)) + try.assume + (format.run /class.writer)) + loader (/loader.memory (/loader.new-library []))]] + (_.test "Class & interface inheritance" + (case (do try.monad + [_ (/loader.define abstract-class abstract-bytecode loader) + _ (/loader.define interface-class interface-bytecode loader) + _ (/loader.define concrete-class concrete-bytecode loader) + class (io.run (/loader.load concrete-class loader)) + method (host.try (get-method static-method class)) + output (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method)] + (wrap (:coerce Int output))) + (#try.Success actual) + (i.= expected actual) + + (#try.Failure error) + false)))) + (def: #export test Test (<| (_.context (%.name (name-of .._))) ($_ _.and - ..instruction + (<| (_.context "instruction") + ..instruction) + (<| (_.context "inheritance") + ..inheritance) ))) -- cgit v1.2.3