diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 172 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode/instruction.lux | 23 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode/jump.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 199 |
4 files changed, 330 insertions, 71 deletions
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux index cb0df3383..4175cc572 100644 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -132,6 +132,15 @@ (: (Monad Try)) try.monad)) +(def: #export (fail error) + (-> Text Bytecode) + (function (_ [pool environment tracker]) + (#try.Failure error))) + +(def: #export (throw exception value) + (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]))) (function (_ pool) @@ -403,19 +412,24 @@ (import: #long java/lang/Float) -(template [<size> <name> <type> <constructor> <constant> <ldc> <to-lux> <specializations>] +(template [<name> <type> <constructor> <constant> <ldc> <to-lux> <specializations>] [(def: #export (<name> value) (-> <type> (Bytecode Any)) (case (|> value <to-lux>) (^template [<special> <instruction>] - <special> (..bytecode $0 <size> @_ <instruction> [])) + <special> (..bytecode $0 $1 @_ <instruction> [])) <specializations> _ (do ..monad [index (..lift (<constant> (<constructor> value)))] - (..bytecode $0 <size> @_ <ldc> [index]))))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @_ _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @_ <ldc> [index])))))] - [$1 int I32 //constant.integer //constant/pool.integer _.ldc-w/integer + [int I32 //constant.integer //constant/pool.integer _.ldc-w/integer (<| .int i32.i64) ([-1 _.iconst-m1] [+0 _.iconst-0] @@ -424,21 +438,48 @@ [+3 _.iconst-3] [+4 _.iconst-4] [+5 _.iconst-5])] - [$2 long Int //constant.long //constant/pool.long _.ldc2-w/long - (<|) - ([+0 _.lconst-0] - [+1 _.lconst-1])] - [$1 float java/lang/Float //constant.float //constant/pool.float _.ldc-w/float + [float java/lang/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 Frac //constant.double //constant/pool.double _.ldc2-w/double + ) + +(template [<name> <type> <constructor> <constant> <ldc> <to-lux> <specializations>] + [(def: #export (<name> value) + (-> <type> (Bytecode Any)) + (case (|> value <to-lux>) + (^template [<special> <instruction>] + <special> (..bytecode $0 $2 @_ <instruction> [])) + <specializations> + + _ (do ..monad + [index (..lift (<constant> (<constructor> value)))] + (..bytecode $0 $2 @_ <ldc> [index]))))] + + [long Int //constant.long //constant/pool.long _.ldc2-w/long + (<|) + ([+0 _.lconst-0] + [+1 _.lconst-1])] + [double Frac //constant.double //constant/pool.double _.ldc2-w/double (<|) ([+0.0 _.dconst-0] [+1.0 _.dconst-1])] ) +(exception: #export (invalid-register {id Nat}) + (exception.report + ["ID" (%.nat id)])) + +(def: #export (register id) + (-> Nat (Bytecode Register)) + (case (//unsigned.u1 id) + (#try.Success register) + (:: ..monad wrap register) + + (#try.Failure error) + (..throw invalid-register [id]))) + (template [<for> <size> <name> <general> <specials>] [(def: #export (<name> local) (-> Register (Bytecode Any)) @@ -524,10 +565,6 @@ [$0 $1 sipush _.sipush U2] ) -(def: #export (ret register) - (-> Register (Bytecode Any)) - (..bytecode $0 $0 (/registry.for register) _.ret [register])) - (exception: #export (unknown-label {label Label}) (exception.report ["Label" (%.nat label)])) @@ -595,6 +632,9 @@ [$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] @@ -604,41 +644,55 @@ [$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]))) - []]]))))))] +(def: #export (goto label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] _.goto] + (function (_ [pool environment tracker]) + (do try.monad + [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: #export (goto-w label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] _.goto-w] + (function (_ [pool environment tracker]) + (do try.monad + [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) + (#try.Success [..no-exceptions (bytecode jump)]) + + (#.Right jump) + (#try.Success [..no-exceptions (bytecode (/jump.lift jump))]))) + + #.None + (exception.throw ..unknown-label [label]))) + []]])))))) (def: (big-jump jump) (-> Any-Jump Big-Jump) @@ -651,14 +705,14 @@ (exception: #export invalid-tableswitch) -(def: #export (tableswitch minimum default cases) - (-> S4 Label (List Label) (Bytecode Any)) +(def: #export (tableswitch minimum default [at-minimum afterwards]) + (-> S4 Label [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))] + program-counter' (step (estimator (list.size afterwards)) (get@ #program-counter tracker))] (wrap (let [@from (get@ #program-counter tracker)] [[pool environment' (set@ #program-counter program-counter' tracker)] [(function (_ resolver) @@ -667,14 +721,16 @@ (dictionary.get label resolver)))] (case (do maybe.monad [@default (get default) - @cases (monad.map @ get cases)] - (wrap [@default @cases])) - (#.Some [@default @cases]) + @at-minimum (get at-minimum) + @afterwards (monad.map @ get afterwards)] + (wrap [@default @at-minimum @afterwards])) + (#.Some [@default @at-minimum @afterwards]) (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)])) + >at-minimum (:: @ map ..big-jump (..jump @from @at-minimum)) + >afterwards (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump)) + @afterwards)] + (#try.Success [..no-exceptions (bytecode minimum >default [>at-minimum >afterwards])])) #.None (exception.throw ..invalid-tableswitch [])))) @@ -684,7 +740,11 @@ (def: #export (lookupswitch default cases) (-> Label (List [S4 Label]) (Bytecode Any)) - (let [[estimator bytecode] _.lookupswitch] + (let [cases (list.sort (function (_ [left _] [right _]) + (i.< (//signed.value left) + (//signed.value right))) + cases) + [estimator bytecode] _.lookupswitch] (function (_ [pool environment tracker]) (do try.monad [environment' (|> environment diff --git a/stdlib/source/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/lux/target/jvm/bytecode/instruction.lux index 2f26586c7..e729efdd3 100644 --- a/stdlib/source/lux/target/jvm/bytecode/instruction.lux +++ b/stdlib/source/lux/target/jvm/bytecode/instruction.lux @@ -555,23 +555,23 @@ (def: #export tableswitch [(-> Nat Estimator) - (-> S4 Big-Jump (List Big-Jump) Instruction)] + (-> S4 Big-Jump [Big-Jump (List Big-Jump)] Instruction)] (let [estimator (: (-> Nat Estimator) - (function (_ amount-of-cases offset) + (function (_ amount-of-afterwards offset) (|> ($_ n.+ (///unsigned.value ..opcode-size) (switch-padding (///unsigned.value (//address.value offset))) (///unsigned.value ..big-jump-size) (///unsigned.value ..integer-size) (///unsigned.value ..integer-size) - (n.* amount-of-cases - (///unsigned.value ..big-jump-size))) + (n.* (///unsigned.value ..big-jump-size) + (inc amount-of-afterwards))) ///unsigned.u2 try.assume)))] [estimator - (function (_ minimum default cases) - (let [amount-of-cases (list.size cases) - estimator (estimator amount-of-cases)] + (function (_ minimum default [at-minimum afterwards]) + (let [amount-of-afterwards (list.size afterwards) + estimator (estimator amount-of-afterwards)] (function (_ [size mutation]) (let [padding (switch-padding size) tableswitch-size (try.assume @@ -584,8 +584,8 @@ [(n.+ tableswitch-size offset) (try.assume (do try.monad - [amount-of-cases (|> amount-of-cases .int ///signed.s4) - maximum (///signed.+/4 minimum amount-of-cases) + [amount-of-afterwards (|> amount-of-afterwards .int ///signed.s4) + maximum (///signed.+/4 minimum amount-of-afterwards) _ (binary.write/8 offset (hex "AA") binary) #let [offset (n.+ (///unsigned.value ..opcode-size) offset)] _ (case padding @@ -602,8 +602,9 @@ #let [offset (n.+ (///unsigned.value ..integer-size) offset)] _ (binary.write/32 offset (///signed.value maximum) binary)] (loop [offset (n.+ (///unsigned.value ..integer-size) offset) - cases cases] - (case cases + afterwards (: (List Big-Jump) + (#.Cons at-minimum afterwards))] + (case afterwards #.Nil (wrap binary) diff --git a/stdlib/source/lux/target/jvm/bytecode/jump.lux b/stdlib/source/lux/target/jvm/bytecode/jump.lux index 47126631c..79ec9fa9b 100644 --- a/stdlib/source/lux/target/jvm/bytecode/jump.lux +++ b/stdlib/source/lux/target/jvm/bytecode/jump.lux @@ -1,7 +1,10 @@ (.module: [lux #* [abstract - [equivalence (#+ Equivalence)]]] + [equivalence (#+ Equivalence)]] + [data + ["." format #_ + ["#" binary (#+ Writer)]]]] ["." /// #_ [encoding ["#." signed (#+ S2 S4)]]]) @@ -9,9 +12,11 @@ (type: #export Jump S2) (def: #export equivalence + (Equivalence Jump) ///signed.equivalence) (def: #export writer + (Writer Jump) ///signed.writer/2) (type: #export Big-Jump S4) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 1ab7ed5ab..f0e6b2b91 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -13,6 +13,7 @@ ["!" capability]]] [data [binary (#+ Binary)] + ["." maybe] ["." bit ("#@." equivalence)] [number ["." i32 (#+ I32)] @@ -27,7 +28,9 @@ [collection ["." array] ["." dictionary] - ["." row]]] + ["." row] + ["." set] + ["." list ("#@." functor)]]] [world ["." file (#+ File)]] [math @@ -47,8 +50,9 @@ ["#/." pool]] [encoding ["#." name] + ["#." signed] ["#." unsigned]] - ["#" bytecode (#+ Bytecode) + ["#" bytecode (#+ Label Bytecode) ["#." instruction] [environment [limit @@ -945,7 +949,24 @@ (_.lift "ISTORE/ILOAD" (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [/.istore /.iload] (function (_ expected actual) - (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected)))))))) + (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected))))) + (_.lift "IINC" + (do random.monad + [base ..$Byte::random + increment (:: @ map (|>> (n.% 100) /unsigned.u1 try.assume) + random.nat) + #let [expected ("jvm ladd" + (host.byte-to-long base) + (.int (/unsigned.value increment)))]] + (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)) + (do /.monad + [_ (..$Byte::literal base) + _ /.istore-0 + @0 (/.register 0) + _ (/.iinc @0 increment) + _ /.iload-0 + _ /.i2l] + ..$Long::wrap))))))) (<| (_.context "long") (let [test-long (: (-> Int Int (-> Any Bit)) (function (_ parameter subject) @@ -1159,11 +1180,183 @@ (function (_ expected actual) (text@= expected (:coerce java/lang/String actual))))) ))) +(def: branching + Test + (do random.monad + [expected ..$Long::random + dummy ..$Long::random + #let [if! (: (-> (-> Label (Bytecode Any)) (Bytecode Any) (Random Bit)) + (function (_ instruction prelude) + (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (do /.monad + [@then /.new-label + @end /.new-label + _ prelude + _ (instruction @then) + _ (..$Long::literal dummy) + _ (/.goto @end) + _ (/.set-label @then) + _ (..$Long::literal expected) + _ (/.set-label @end)] + ..$Long::wrap)))) + comparison-against-zero ($_ _.and + (_.lift "IFEQ" (if! /.ifeq /.iconst-0)) + (_.lift "IFNE" (if! /.ifne /.iconst-1)) + (_.lift "IFLT" (if! /.iflt /.iconst-m1)) + (_.lift "IFLE" (if! /.ifle /.iconst-0)) + (_.lift "IFGT" (if! /.ifgt /.iconst-1)) + (_.lift "IFGE" (if! /.ifge /.iconst-0))) + null-test ($_ _.and + (_.lift "IFNULL" (if! /.ifnull /.aconst-null)) + (_.lift "IFNONNULL" (if! /.ifnonnull (/.string ""))))] + reference ..$Integer::random + subject (|> ..$Integer::random + (random.filter (|>> ("jvm ieq" reference) not))) + #let [[lesser greater] (if ("jvm ilt" reference subject) + [reference subject] + [subject reference]) + int-comparison ($_ _.and + (_.lift "IF_ICMPEQ" (if! /.if-icmpeq (do /.monad [_ (..$Integer::literal reference)] /.dup))) + (_.lift "IF_ICMPNE" (if! /.if-icmpne (do /.monad [_ (..$Integer::literal reference)] (..$Integer::literal subject)))) + (_.lift "IF_ICMPLT" (if! /.if-icmplt (do /.monad [_ (..$Integer::literal lesser)] (..$Integer::literal greater)))) + (_.lift "IF_ICMPLE" (if! /.if-icmple (do /.monad [_ (..$Integer::literal lesser)] (..$Integer::literal greater)))) + (_.lift "IF_ICMPGT" (if! /.if-icmpgt (do /.monad [_ (..$Integer::literal greater)] (..$Integer::literal lesser)))) + (_.lift "IF_ICMPGE" (if! /.if-icmpge (do /.monad [_ (..$Integer::literal greater)] (..$Integer::literal lesser))))) + new-object (: (Bytecode Any) + (do /.monad + [_ (/.new ..$Object) + _ /.dup] + (/.invokespecial ..$Object "<init>" (/type.method [(list) /type.void (list)])))) + reference-comparison ($_ _.and + (_.lift "IF_ACMPEQ" (if! /.if-acmpeq (do /.monad [_ new-object] /.dup))) + (_.lift "IF_ACMPNE" (if! /.if-acmpne (do /.monad [_ new-object] new-object))) + )]] + ($_ _.and + comparison-against-zero + null-test + int-comparison + reference-comparison + ))) + +(def: jump + Test + (do random.monad + [expected ..$Long::random + dummy ..$Long::random + #let [jump (: (-> (-> Label (Bytecode Any)) (Random Bit)) + (function (_ goto) + (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (do /.monad + [^value /.new-label + ^end /.new-label + _ (goto ^value) + _ (..$Long::literal dummy) + _ (goto ^end) + _ (/.set-label ^value) + _ (..$Long::literal expected) + _ (/.set-label ^end)] + ..$Long::wrap))))]] + ($_ _.and + (_.lift "GOTO" (jump /.goto)) + (_.lift "GOTO_W" (jump /.goto-w))))) + +(def: switch + Test + ($_ _.and + (<| (_.lift "TABLESWITCH") + (do random.monad + [expected ..$Long::random + dummy ..$Long::random + minimum (:: @ map (|>> (n.% 100) .int /signed.s4 try.assume) + random.nat) + afterwards (:: @ map (n.% 10) random.nat)]) + (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (do /.monad + [^right /.new-label + ^wrong /.new-label + ^return /.new-label + _ (/.bipush (|> minimum /signed.value .nat /unsigned.u1 try.assume)) + _ (/.tableswitch minimum ^wrong [^right (list.repeat afterwards ^wrong)]) + _ (/.set-label ^wrong) + _ (..$Long::literal dummy) + _ (/.goto ^return) + _ (/.set-label ^right) + _ (..$Long::literal expected) + _ (/.set-label ^return)] + ..$Long::wrap)) + (<| (_.lift "LOOKUPSWITCH") + (do random.monad + [options (:: @ map (|>> (n.% 10) (n.+ 1)) + random.nat) + choice (:: @ map (n.% options) random.nat) + options (|> random.int + (:: @ map (|>> host.long-to-int host.int-to-long)) + (random.set i.hash options) + (:: @ map set.to-list)) + #let [choice (maybe.assume (list.nth choice options))] + expected ..$Long::random + dummy ..$Long::random]) + (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (do /.monad + [^right /.new-label + ^wrong /.new-label + ^return /.new-label + _ (..$Integer::literal (host.long-to-int choice)) + _ (/.lookupswitch ^wrong (list@map (function (_ option) + [(|> option /signed.s4 try.assume) + (if (i.= choice option) ^right ^wrong)]) + options)) + _ (/.set-label ^wrong) + _ (..$Long::literal dummy) + _ (/.goto ^return) + _ (/.set-label ^right) + _ (..$Long::literal expected) + _ (/.set-label ^return)] + ..$Long::wrap)) + )) + +(def: exception + Test + (do random.monad + [expected ..$Long::random + dummy ..$Long::random + exception ..$String::random] + (<| (_.lift "ATHROW") + (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (do /.monad + [#let [$Exception (/type.class "java.lang.Exception" (list))] + ^start /.new-label + ^end /.new-label + ^handler /.new-label + ^return /.new-label + _ (/.try ^start ^end ^handler $Exception) + _ (/.set-label ^start) + _ (/.new $Exception) + _ /.dup + _ (..$String::literal exception) + _ (/.invokespecial $Exception "<init>" (/type.method [(list ..$String) /type.void (list)])) + _ /.athrow + _ (..$Long::literal dummy) + _ (/.goto ^return) + _ (/.set-label ^end) + _ (/.set-label ^handler) + _ (..$Long::literal expected) + _ (/.set-label ^return)] + ..$Long::wrap)))) + (def: code Test ($_ _.and (<| (_.context "return") ..return) + (<| (_.context "branching") + ..branching) + (<| (_.context "jump") + ..jump) + (<| (_.context "switch") + ..switch) + (<| (_.context "exception") + ..exception) )) (def: instruction |