aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2019-11-16 22:40:58 -0400
committerEduardo Julian2019-11-16 22:40:58 -0400
commita5a71a224408b6a7a736fd2f4c06646bf5c89fd8 (patch)
tree6cee733ec9e636153e25f9a588098b45ed728868 /stdlib/source
parent7ddf25a555265b8cd8218b368fc66e416c60abe9 (diff)
Tests for JVM bytecode machinery. [Part 5]
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux.lux4
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux6
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment.lux21
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit.lux25
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux47
-rw-r--r--stdlib/source/lux/target/jvm/instruction.lux722
-rw-r--r--stdlib/source/lux/target/jvm/instruction/bytecode.lux660
-rw-r--r--stdlib/source/lux/target/jvm/method.lux39
-rw-r--r--stdlib/source/lux/target/jvm/modifier.lux35
-rw-r--r--stdlib/source/test/lux/target/jvm.lux225
10 files changed, 311 insertions, 1473 deletions
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 [<name> <limit>]
+ [(def: #export (<name> type)
+ (-> (Type Method) (Try Environment))
+ (do try.monad
+ [limit (<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 [<name> <registry>]
+ [(def: #export (<name> type)
+ (-> (Type Method) (Try Limit))
+ (do try.monad
+ [registry (<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 [<start> <name>]
+ [(def: #export <name>
+ (-> (Type Method) (Try Registry))
+ (|>> ..minimal
+ (n.+ <start>)
+ /////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 [<name> <bytecode>]
- [(def: #export <name> (..opcode <bytecode> []))]
-
- [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 [<name> <type> <constant> <ldc> <to-lux> <specializations>]
- [(def: #export (<name> value)
- (-> <type> (Instruction Any))
- (case (|> value //constant.value <to-lux>)
- (^template [<special> <bytecode>]
- <special> (..opcode <bytecode> []))
- <specializations>
-
- _ (do ..monad
- [index (..lift (<constant> value))]
- (..opcode <ldc> [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 [<name> <bytecode> <input> <0> <1> <2> <3>]
- [(def: #export (<name> local)
- (-> <input> (Instruction Any))
- (case (//unsigned.nat local)
- 0 (..opcode <0> [])
- 1 (..opcode <1> [])
- 2 (..opcode <2> [])
- 3 (..opcode <3> [])
- _ (..opcode <bytecode> [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 [<name> <bytecode> <input>]
- [(def: #export <name>
- (-> <input> (Instruction Any))
- (..opcode <bytecode>))]
-
- [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 [<name> <bytecode>]
- [(def: #export (<name> label)
- (-> Label (Instruction Any))
- (let [[estimator bytecode] <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 [<name> <normal-bytecode> <wide-bytecode>]
- [(def: #export (<name> label)
- (-> Label (Instruction Any))
- (let [[normal-estimator normal-bytecode] <normal-bytecode>
- ## TODO: No more polymorphic GOTO and JSR.
- ## [wide-estimator wide-bytecode] <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 (<wide-bytecode> 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 [<name> <category> <bytecode>]
- [(def: #export (<name> class)
- (-> (Type <category>) (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 <bytecode> [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 [<static?> <name> <bytecode>]
- [(def: #export (<name> 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 <bytecode>
- [index
- (|> inputs
- (list@map ..type-size)
- (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
- (..type-size output)]))))]
-
- [#1 invokestatic _.invokestatic]
- [#0 invokevirtual _.invokevirtual]
- [#0 invokespecial _.invokespecial]
- [#0 invokeinterface _.invokeinterface]
- )
-
-(template [<name> <1> <2>]
- [(def: #export (<name> 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 [<shift> <name> <inputT> <writer> <unwrap>]
- [(with-expansions [<private> (template.identifier [<name> "'"])]
- (def: (<private> code input0)
- (-> Code <inputT> Mutation)
- (function (_ [offset binary])
- [(n.+ <shift> offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset code binary)]
- (<writer> (n.+ 1 offset) (<unwrap> input0) binary)))]))
-
- (def: <name>
- [Estimator
- (-> Code <inputT> Opcode)]
- [(..fixed <shift>)
- (function (_ code input0 [size mutation])
- [(n.+ <shift> size)
- (|>> mutation ((<private> 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 [<code> <name>]
- [(def: #export <name> (|> <code> ///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 [<constants> (template [<code> <name> <output-size>]
- [[<code> <name> [] [] 0 <output-size> []]]
-
- ["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])
- <local-loads> (template [<code> <name> <output-size>]
- [[<code> <name> [[local Local]] [local] 0 <output-size> [[local]]]]
-
- ["15" iload 1]
- ["16" lload 2]
- ["17" fload 1]
- ["18" dload 2]
- ["19" aload 1])
- <simple-local-loads> (template [<code> <name> <output-size> <local-end>]
- [[<code> <name> [] [] 0 <output-size> [[(///unsigned.u1 <local-end>)]]]]
-
- ["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])
- <local-stores> (template [<code> <name> <input-size>]
- [[<code> <name> [[local Local]] [local] <input-size> 0 [[local]]]]
-
- ["36" istore 1]
- ["37" lstore 2]
- ["38" fstore 1]
- ["39" dstore 2]
- ["3A" astore 1])
- <simple-local-stores> (template [<code> <name> <input-size> <local-end>]
- [[<code> <name> [] [] <input-size> 0 [[(///unsigned.u1 <local-end>)]]]]
-
- ["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])
- <array-loads> (template [<code> <name> <output-size>]
- [[<code> <name> [] [] 2 <output-size> []]]
-
- ["2E" iaload 1]
- ["2F" laload 2]
- ["30" faload 1]
- ["31" daload 2]
- ["32" aaload 1]
- ["33" baload 1]
- ["34" caload 1]
- ["35" saload 1])
- <array-stores> (template [<code> <name> <input-size>]
- [[<code> <name> [] [] <input-size> 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])
- <arithmetic> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [] [] <input-size> <output-size> []]]
-
- ["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])
- <conversions> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [] [] <input-size> <output-size> []]]
-
- ["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])
- <comparisons> (template [<code> <name> <input-size>]
- [[<code> <name> [] [] <input-size> 1 []]]
-
- ["94" lcmp 4]
-
- ["95" fcmpl 2]
- ["96" fcmpg 2]
-
- ["97" dcmpl 4]
- ["98" dcmpg 4])
- <returns> (template [<code> <name> <input-size>]
- [[<code> <name> [] [] <input-size> 0 []]]
-
- ["AC" ireturn 1]
- ["AD" lreturn 2]
- ["AE" freturn 1]
- ["AF" dreturn 2]
- ["B0" areturn 1]
- ["B1" return 0]
- )
- <jumps> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [[jump Jump]] [jump] <input-size> <output-size> []]]
-
- ["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])
- <fields> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [[index (Index (Reference Value))]] [(///index.number index)] <input-size> <output-size> []]]
-
- ["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 [<arity> <definitions>]
- [(with-expansions [<definitions>' (template.splice <definitions>)]
- (template [<code> <name> <bytecode-inputs> <arity-inputs> <consumes> <produces> <locals>]
- [(with-expansions [<inputs>' (template.splice <bytecode-inputs>)
- <input-types> (template [<input-name> <input-type>]
- [<input-type>]
-
- <inputs>')
- <input-names> (template [<input-name> <input-type>]
- [<input-name>]
-
- <inputs>')
- <locals>' (template.splice <locals>)]
- (def: #export <name>
- [Estimator
- (-> [<input-types>] Bytecode)]
- (let [[estimator <arity>'] <arity>]
- [estimator
- (function (_ [<input-names>])
- (..bytecode
- (`` ($_ /@compose
- (/.consumes <consumes>)
- (/.produces <produces>)
- (~~ (template [<local>]
- [(/.has-local <local>)]
-
- <locals>'))))
- (`` (<arity>' (hex <code>) (~~ (template.splice <arity-inputs>))))))])))]
-
- <definitions>'
- ))]
-
- [..nullary
- [["00" nop [] [] 0 0 []]
- <constants>
- ["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 []]
- <simple-local-loads>
- <array-loads>
- <simple-local-stores>
- <array-stores>
- <arithmetic>
- ["79" lshl [] [] 3 2 []]
- ["7B" lshr [] [] 3 2 []]
- ["7D" lushr [] [] 3 2 []]
- <conversions>
- <comparisons>
- <returns>
- ["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 []]
- <local-loads>
- <local-stores>
- ["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 []]
- <fields>
- ["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
- [<jumps>]]
-
- [..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 <c>.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 "<init>"
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 "<init>" (/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 "<init>" 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
+ "<init>"
+ constructor::type
+ (list)
+ (#.Some (do /.monad
+ [_ /.aload-0
+ _ (/.invokespecial ..$Object "<init>" 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
+ "<init>"
+ constructor::type
+ (list)
+ (#.Some (do /.monad
+ [_ /.aload-0
+ _ (/.invokespecial $Abstract "<init>" 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 "<init>" 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)
)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 03:11:29 +0000