aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux172
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/instruction.lux23
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/jump.lux7
-rw-r--r--stdlib/source/test/lux/target/jvm.lux199
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