aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux22
-rw-r--r--stdlib/source/lux/target/jvm/instruction.lux779
-rw-r--r--stdlib/source/lux/target/jvm/instruction/address.lux31
-rw-r--r--stdlib/source/lux/target/jvm/instruction/bytecode.lux360
-rw-r--r--stdlib/source/lux/target/jvm/instruction/condition.lux4
-rw-r--r--stdlib/source/lux/target/jvm/method.lux24
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux27
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux594
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux2
19 files changed, 1309 insertions, 647 deletions
diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
index 17111c251..97fe962e6 100644
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
@@ -12,22 +12,22 @@
[constant (#+ Class)]
["#." index (#+ Index)]
[instruction
- ["#." jump (#+ Jump)]]
+ ["#." address (#+ Address)]]
[encoding
["#." unsigned (#+ U2)]]]])
(type: #export Exception
- {#start-pc Jump
- #end-pc Jump
- #handler-pc Jump
- #catch-type (Index Class)})
+ {#start Address
+ #end Address
+ #handler Address
+ #catch (Index Class)})
(def: #export equivalence
(Equivalence Exception)
($_ equivalence.product
- ////jump.equivalence
- ////jump.equivalence
- ////jump.equivalence
+ ////address.equivalence
+ ////address.equivalence
+ ////address.equivalence
////index.equivalence
))
@@ -48,8 +48,8 @@
(def: #export writer
(Writer Exception)
($_ binaryF.and
- ////jump.writer
- ////jump.writer
- ////jump.writer
+ ////address.writer
+ ////address.writer
+ ////address.writer
////index.writer
))
diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux
index 59e4b7b44..210439df3 100644
--- a/stdlib/source/lux/target/jvm/instruction.lux
+++ b/stdlib/source/lux/target/jvm/instruction.lux
@@ -1,5 +1,6 @@
(.module:
[lux (#- Type)
+ ["." host]
[abstract
[monoid (#+ Monoid)]
["." monad (#+ Monad do)]]
@@ -16,22 +17,28 @@
["%" format (#+ format)]]
[number
["n" nat]
- ["i" int]]
+ ["i" int]
+ ["." i32]]
[collection
["." list ("#@." functor fold)]
- ["." dictionary (#+ Dictionary)]]]]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row)]]]]
["." / #_
- ["#." condition (#+ Local)]
+ ["#." condition (#+ Stack Local)]
+ ["#." address]
["#." jump (#+ Jump Big-Jump)]
- ["#." bytecode (#+ Primitive-Array-Type Bytecode) ("#@." monoid)]
+ ["_" bytecode (#+ Primitive-Array-Type Bytecode Estimator) ("#@." monoid)]
["/#" // #_
- ["#." index]
+ ["#." 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]
@@ -42,10 +49,10 @@
(-> (Type (<| Return' Value' category)) Text))
(|>> type.reflection reflection.reflection))
-(type: #export Label Nat)
-
(type: #export Address Nat)
+(type: #export Label Nat)
+
(type: #export Resolver (Dictionary Label Address))
(type: #export Tracker
@@ -60,11 +67,19 @@
#known-labels (dictionary.new n.hash)})
(type: #export Partial
- (-> Resolver (Try Bytecode)))
+ (-> 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 /bytecode.nop)))
+ (function.constant (#try.Success [..no-exceptions ..no-bytecode])))
(structure: partial-monoid
(Monoid Partial)
@@ -81,9 +96,10 @@
## else
(function (_ resolver)
(do try.monad
- [left (left resolver)
- right (right resolver)]
- (wrap (/bytecode@compose left right)))))))
+ [[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)))
@@ -116,188 +132,223 @@
state.monad))))
(def: #export (resolve instruction)
- (All [a] (-> (Instruction a) (State Pool (Try [Bytecode a]))))
+ (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
- [bytecode (partial (get@ #known-labels tracker))]
- (wrap [bytecode output]))])))
+ [[exceptions bytecode] (partial (get@ #known-labels tracker))]
+ (wrap [bytecode exceptions output]))])))
-(def: (nullary bytecode)
- (-> Bytecode (Instruction Any))
+(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 tracker]
- [(function.constant (#try.Success bytecode))
+ [[pool (update@ #program-counter (count estimator) tracker)]
+ [(function.constant (#try.Success [..no-exceptions (bytecode input)]))
[]]]))
(template [<name> <bytecode>]
- [(def: #export <name> (nullary <bytecode>))]
-
- [nop /bytecode.nop]
- [aconst-null /bytecode.aconst-null]
-
- [iconst-m1 /bytecode.iconst-m1]
- [iconst-0 /bytecode.iconst-0]
- [iconst-1 /bytecode.iconst-1]
- [iconst-2 /bytecode.iconst-2]
- [iconst-3 /bytecode.iconst-3]
- [iconst-4 /bytecode.iconst-4]
- [iconst-5 /bytecode.iconst-5]
+ [(def: #export <name> (..opcode <bytecode> []))]
- [lconst-0 /bytecode.lconst-0]
- [lconst-1 /bytecode.lconst-1]
-
- [fconst-0 /bytecode.fconst-0]
- [fconst-1 /bytecode.fconst-1]
- [fconst-2 /bytecode.fconst-2]
+ [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 /bytecode.dconst-0]
- [dconst-1 /bytecode.dconst-1]
+ [dconst-0 _.dconst-0]
+ [dconst-1 _.dconst-1]
- [pop /bytecode.pop]
- [pop2 /bytecode.pop2]
+ [pop _.pop]
+ [pop2 _.pop2]
+
+ [dup _.dup]
+ [dup-x1 _.dup-x1]
+ [dup-x2 _.dup-x2]
+ [dup2 _.dup2]
+ [dup2-x1 _.dup2-x1]
+ [dup2-x2 _.dup2-x2]
- [dup /bytecode.dup]
- [dup-x1 /bytecode.dup-x1]
- [dup-x2 /bytecode.dup-x2]
- [dup2 /bytecode.dup2]
- [dup2-x1 /bytecode.dup2-x1]
- [dup2-x2 /bytecode.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]
- [swap /bytecode.swap]
-
- [istore-0 /bytecode.istore-0]
- [istore-1 /bytecode.istore-1]
- [istore-2 /bytecode.istore-2]
- [istore-3 /bytecode.istore-3]
-
- [lstore-0 /bytecode.lstore-0]
- [lstore-1 /bytecode.lstore-1]
- [lstore-2 /bytecode.lstore-2]
- [lstore-3 /bytecode.lstore-3]
-
- [fstore-0 /bytecode.fstore-0]
- [fstore-1 /bytecode.fstore-1]
- [fstore-2 /bytecode.fstore-2]
- [fstore-3 /bytecode.fstore-3]
-
- [dstore-0 /bytecode.dstore-0]
- [dstore-1 /bytecode.dstore-1]
- [dstore-2 /bytecode.dstore-2]
- [dstore-3 /bytecode.dstore-3]
+ [fload-0 _.fload-0]
+ [fload-1 _.fload-1]
+ [fload-2 _.fload-2]
+ [fload-3 _.fload-3]
- [astore-0 /bytecode.astore-0]
- [astore-1 /bytecode.astore-1]
- [astore-2 /bytecode.astore-2]
- [astore-3 /bytecode.astore-3]
-
- [iaload /bytecode.iaload]
- [laload /bytecode.laload]
- [faload /bytecode.faload]
- [daload /bytecode.daload]
- [aaload /bytecode.aaload]
- [baload /bytecode.baload]
- [caload /bytecode.caload]
- [saload /bytecode.saload]
-
- [iastore /bytecode.iastore]
- [lastore /bytecode.lastore]
- [fastore /bytecode.fastore]
- [dastore /bytecode.dastore]
- [aastore /bytecode.aastore]
- [bastore /bytecode.bastore]
- [castore /bytecode.castore]
- [sastore /bytecode.sastore]
-
- [iadd /bytecode.iadd]
- [isub /bytecode.isub]
- [imul /bytecode.imul]
- [idiv /bytecode.idiv]
- [irem /bytecode.irem]
- [ineg /bytecode.ineg]
- [ishl /bytecode.ishl]
- [ishr /bytecode.ishr]
- [iushr /bytecode.iushr]
- [iand /bytecode.iand]
- [ior /bytecode.ior]
- [ixor /bytecode.ixor]
-
- [ladd /bytecode.ladd]
- [lsub /bytecode.lsub]
- [lmul /bytecode.lmul]
- [ldiv /bytecode.ldiv]
- [lrem /bytecode.lrem]
- [lneg /bytecode.lneg]
- [land /bytecode.land]
- [lor /bytecode.lor]
- [lxor /bytecode.lxor]
+ [dload-0 _.dload-0]
+ [dload-1 _.dload-1]
+ [dload-2 _.dload-2]
+ [dload-3 _.dload-3]
- [fadd /bytecode.fadd]
- [fsub /bytecode.fsub]
- [fmul /bytecode.fmul]
- [fdiv /bytecode.fdiv]
- [frem /bytecode.frem]
- [fneg /bytecode.fneg]
+ [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]
- [dadd /bytecode.dadd]
- [dsub /bytecode.dsub]
- [dmul /bytecode.dmul]
- [ddiv /bytecode.ddiv]
- [drem /bytecode.drem]
- [dneg /bytecode.dneg]
-
- [lshl /bytecode.lshl]
- [lshr /bytecode.lshr]
- [lushr /bytecode.lushr]
-
- [l2i /bytecode.l2i]
- [l2f /bytecode.l2f]
- [l2d /bytecode.l2d]
+ [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]
- [f2i /bytecode.f2i]
- [f2l /bytecode.f2l]
- [f2d /bytecode.f2d]
+ [fadd _.fadd]
+ [fsub _.fsub]
+ [fmul _.fmul]
+ [fdiv _.fdiv]
+ [frem _.frem]
+ [fneg _.fneg]
- [d2i /bytecode.d2i]
- [d2l /bytecode.d2l]
- [d2f /bytecode.d2f]
-
- [i2l /bytecode.i2l]
- [i2f /bytecode.i2f]
- [i2d /bytecode.i2d]
- [i2b /bytecode.i2b]
- [i2c /bytecode.i2c]
- [i2s /bytecode.i2s]
-
- [lcmp /bytecode.lcmp]
+ [dadd _.dadd]
+ [dsub _.dsub]
+ [dmul _.dmul]
+ [ddiv _.ddiv]
+ [drem _.drem]
+ [dneg _.dneg]
+
+ [lshl _.lshl]
+ [lshr _.lshr]
+ [lushr _.lushr]
+
+ [l2i _.l2i]
+ [l2f _.l2f]
+ [l2d _.l2d]
- [fcmpl /bytecode.fcmpl]
- [fcmpg /bytecode.fcmpg]
+ [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 /bytecode.dcmpl]
- [dcmpg /bytecode.dcmpg]
+ [dcmpl _.dcmpl]
+ [dcmpg _.dcmpg]
- [ireturn /bytecode.ireturn]
- [lreturn /bytecode.lreturn]
- [freturn /bytecode.freturn]
- [dreturn /bytecode.dreturn]
- [areturn /bytecode.areturn]
- [return /bytecode.return]
+ [ireturn _.ireturn]
+ [lreturn _.lreturn]
+ [freturn _.freturn]
+ [dreturn _.dreturn]
+ [areturn _.areturn]
+ [return _.return]
- [arraylength /bytecode.arraylength]
+ [arraylength _.arraylength]
- [athrow /bytecode.athrow]
+ [athrow _.athrow]
- [monitorenter /bytecode.monitorenter]
- [monitorexit /bytecode.monitorexit]
+ [monitorenter _.monitorenter]
+ [monitorexit _.monitorexit]
)
(def: #export (bipush byte)
(-> U1 (Instruction Any))
- (function (_ [pool tracker])
- [[pool tracker]
- [(function.constant (#try.Success (/bytecode.bipush byte)))
- []]]))
+ (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]
@@ -312,54 +363,82 @@
(def: max-u1
(|> //unsigned.max-u1 //unsigned.nat //unsigned.u2))
-(template [<name> <type> <constant> <ldc>]
- [(def: #export (<name> value)
- (-> <type> (Instruction Any))
- (do ..monad
- [index (..lift (<constant> value))
- #let [index' (//index.number index)]]
- (..nullary (if (:: //unsigned.order < ..max-u1 index')
- (/bytecode.ldc (|> index' //unsigned.nat //unsigned.u1))
- (<ldc> index)))))]
-
- [ldc/string //constant.UTF8 //constant/pool.string /bytecode.ldc-w/string]
- )
+(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>]
+(template [<name> <type> <constant> <ldc> <to-lux> <specializations>]
[(def: #export (<name> value)
(-> <type> (Instruction Any))
- (do ..monad
- [index (..lift (<constant> value))]
- (..nullary (<ldc> index))))]
+ (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])]
+ )
- [ldc/integer //constant.Integer //constant/pool.integer /bytecode.ldc-w/integer]
- [ldc/long //constant.Long //constant/pool.long /bytecode.ldc2-w/long]
- [ldc/float //constant.Float //constant/pool.float /bytecode.ldc-w/float]
- [ldc/double //constant.Double //constant/pool.double /bytecode.ldc2-w/double]
+(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))
- (|>> <bytecode> nullary))]
-
- [iload /bytecode.iload Local]
- [lload /bytecode.lload Local]
- [fload /bytecode.fload Local]
- [dload /bytecode.dload Local]
- [aload /bytecode.aload Local]
-
- [istore /bytecode.istore Local]
- [lstore /bytecode.lstore Local]
- [fstore /bytecode.fstore Local]
- [dstore /bytecode.dstore Local]
- [astore /bytecode.astore Local]
-
- [ret /bytecode.ret Local]
-
- [newarray /bytecode.newarray Primitive-Array-Type]
-
- [sipush /bytecode.sipush U2]
+ (..opcode <bytecode>))]
+
+ [ret _.ret Local]
+ [newarray _.newarray Primitive-Array-Type]
+ [sipush _.sipush U2]
)
(exception: #export (unknown-label {label Label})
@@ -386,69 +465,83 @@
(#.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))
- (function (_ [pool tracker])
- (let [@from (get@ #program-counter tracker)]
- [[pool tracker]
- [(function (_ resolver)
- (case (dictionary.get label resolver)
- (#.Some @to)
- (case (jump @from @to)
- (#.Left jump)
- (#try.Success (<bytecode> jump))
-
- (#.Right jump)
- (exception.throw ..cannot-do-a-big-jump [label @from jump]))
-
- #.None
- (exception.throw ..unknown-label [label])))
- []]])))]
-
- [ifeq /bytecode.ifeq]
- [ifne /bytecode.ifne]
- [iflt /bytecode.iflt]
- [ifge /bytecode.ifge]
- [ifgt /bytecode.ifgt]
- [ifle /bytecode.ifle]
+ (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 /bytecode.if-icmpeq]
- [if-icmpne /bytecode.if-icmpne]
- [if-icmplt /bytecode.if-icmplt]
- [if-icmpge /bytecode.if-icmpge]
- [if-icmpgt /bytecode.if-icmpgt]
- [if-icmple /bytecode.if-icmple]
+ [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 /bytecode.if-acmpeq]
- [if-acmpne /bytecode.if-acmpne]
+ [if-acmpeq _.if-acmpeq]
+ [if-acmpne _.if-acmpne]
- [ifnull /bytecode.ifnull]
- [ifnonnull /bytecode.ifnonnull]
+ [ifnull _.ifnull]
+ [ifnonnull _.ifnonnull]
)
(template [<name> <normal-bytecode> <wide-bytecode>]
[(def: #export (<name> label)
(-> Label (Instruction Any))
- (function (_ [pool tracker])
- (let [@from (get@ #program-counter tracker)]
- [[pool tracker]
- [(function (_ resolver)
- (case (dictionary.get label resolver)
- (#.Some @to)
- (case (jump @from @to)
- (#.Left jump)
- (#try.Success (<normal-bytecode> jump))
-
- (#.Right jump)
- (#try.Success (<wide-bytecode> jump)))
-
- #.None
- (exception.throw ..unknown-label [label])))
- []]])))]
-
- [goto /bytecode.goto /bytecode.goto-w]
- [jsr /bytecode.jsr /bytecode.jsr-w]
+ (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)
@@ -464,52 +557,54 @@
(def: #export (tableswitch minimum default cases)
(-> S4 Label (List Label) (Instruction Any))
- (function (_ [pool tracker])
- (let [@from (get@ #program-counter tracker)]
- [[pool 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.tableswitch minimum >default >cases)))
- (#.Some bytecode)
- (#try.Success bytecode)
-
- #.None
- (exception.throw ..invalid-tableswitch []))))
- []]])))
+ (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))
- (function (_ [pool tracker])
- (let [@from (get@ #program-counter tracker)]
- [[pool 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.lookupswitch >default >cases)))
- (#.Some bytecode)
- (#try.Success bytecode)
-
- #.None
- (exception.throw ..invalid-lookupswitch []))))
- []]])))
+ (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)
@@ -517,23 +612,23 @@
(do ..monad
## TODO: Make sure it"s impossible to have indexes greater than U2.
[index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
- (..nullary (<bytecode> index))))]
+ (..opcode <bytecode> [index])))]
- [new Class /bytecode.new]
- [anewarray Object /bytecode.anewarray]
- [checkcast Object /bytecode.checkcast]
- [instanceof Object /bytecode.instanceof]
+ [new Class _.new]
+ [anewarray Object _.anewarray]
+ [checkcast Object _.checkcast]
+ [instanceof Object _.instanceof]
)
(def: #export (iinc register increase)
(-> Local U1 (Instruction Any))
- (..nullary (/bytecode.iinc register increase)))
+ (..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))))]
- (..nullary (/bytecode.multianewarray index count))))
+ (..opcode _.multianewarray [index count])))
(def: (type-size type)
(-> (Type Return) U1)
@@ -557,17 +652,17 @@
(//constant/pool.method (..reflection class))
{#//constant/pool.name method
#//constant/pool.descriptor (type.descriptor type)})]
- (..nullary (<bytecode>
- index
- (|> inputs
- (list@map ..type-size)
- (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
- (..type-size output))))))]
-
- [#1 invokestatic /bytecode.invokestatic]
- [#0 invokevirtual /bytecode.invokevirtual]
- [#0 invokespecial /bytecode.invokespecial]
- [#0 invokeinterface /bytecode.invokeinterface]
+ (..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>]
@@ -578,21 +673,47 @@
(//constant/pool.field (..reflection class))
{#//constant/pool.name field
#//constant/pool.descriptor (type.descriptor type)})]
- (..nullary (cond (is? type.long type)
- (<2> index)
-
- (is? type.double type)
- (<2> index)
-
- ## else
- (<1> index)))))]
-
- [getstatic /bytecode.getstatic/1 /bytecode.getstatic/2]
- [putstatic /bytecode.putstatic/1 /bytecode.putstatic/2]
- [getfield /bytecode.getfield/1 /bytecode.getfield/2]
- [putfield /bytecode.putfield/1 /bytecode.putfield/2]
+ (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)))
diff --git a/stdlib/source/lux/target/jvm/instruction/address.lux b/stdlib/source/lux/target/jvm/instruction/address.lux
new file mode 100644
index 000000000..1be4460b2
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/instruction/address.lux
@@ -0,0 +1,31 @@
+(.module:
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ [format
+ [binary (#+ Writer)]]]
+ [type
+ abstract]]
+ ["." /// #_
+ [encoding
+ ["#." unsigned (#+ U2)]]])
+
+(abstract: #export Address
+ {}
+
+ U2
+
+ (def: #export address
+ (-> U2 Address)
+ (|>> :abstraction))
+
+ (structure: #export equivalence
+ (Equivalence Address)
+ (def: (= reference subject)
+ (:: ///unsigned.equivalence = (:representation reference) (:representation subject))))
+
+ (def: #export writer
+ (Writer Address)
+ (|>> :representation ///unsigned.u2-writer))
+ )
diff --git a/stdlib/source/lux/target/jvm/instruction/bytecode.lux b/stdlib/source/lux/target/jvm/instruction/bytecode.lux
index 11afb5ad0..17f57ea1f 100644
--- a/stdlib/source/lux/target/jvm/instruction/bytecode.lux
+++ b/stdlib/source/lux/target/jvm/instruction/bytecode.lux
@@ -4,10 +4,13 @@
[monad (#+ do)]
[monoid (#+ Monoid)]]
[control
+ ["." function]
["." try (#+ Try)]
["." exception (#+ exception:)]
- ["." function]]
+ [parser
+ [binary (#+ Offset)]]]
[data
+ ["." product]
["." binary]
[number (#+ hex)
["n" nat]]
@@ -34,16 +37,26 @@
[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 (-> Specification Specification) Bytecode)
+ (-> Condition Opcode Bytecode)
(function (_ [environment specification])
(do try.monad
[environment' (condition environment)]
@@ -52,9 +65,14 @@
(type: Code Nat)
-(def: code-size 1)
-(def: big-jump-size 4)
-(def: integer-size 4)
+(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)
@@ -63,10 +81,17 @@
(try.assume
(binary.write/8 offset code binary))]))
-(def: (nullary code [size mutation])
- (-> Code (-> Specification Specification))
- [(n.+ ..code-size size)
- (|>> mutation ((nullary' code)))])
+(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> "'"])]
@@ -79,51 +104,66 @@
[_ (binary.write/8 offset code binary)]
(<writer> (n.+ 1 offset) (<unwrap> input0) binary)))]))
- (def: (<name> code input0 [size mutation])
- (-> Code <inputT> (-> Specification Specification))
- [(n.+ <shift> size)
- (|>> mutation ((<private> code input0)))]))]
-
- [2 unary/1 U1 binary.write/8 ///unsigned.nat]
- [3 unary/2 U2 binary.write/16 ///unsigned.nat]
- [3 jump/2 S2 binary.write/16 ///signed.int]
- [5 jump/4 S4 binary.write/32 ///signed.int]
+ (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.+ 3 offset)
+ [(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 code input0 input1 [size mutation])
- (-> Code U1 U1 (-> Specification Specification))
- [(n.+ 3 size)
- (|>> mutation ((binary/11' code input0 input1)))])
+(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.+ 4 offset)
+ [(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 code input0 input1 [size mutation])
- (-> Code U2 U1 (-> Specification Specification))
- [(n.+ 4 size)
- (|>> mutation ((binary/21' code input0 input1)))])
+(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.+ 5 offset)
+ [(n.+ ..size/211 offset)
(try.assume
(do try.monad
[_ (binary.write/8 offset code binary)
@@ -131,10 +171,13 @@
_ (binary.write/8 (n.+ 3 offset) (///unsigned.nat input1) binary)]
(binary.write/8 (n.+ 4 offset) (///unsigned.nat input2) binary)))]))
-(def: (trinary/211 code input0 input1 input2 [size mutation])
- (-> Code U2 U1 U1 (-> Specification Specification))
- [(n.+ 5 size)
- (|>> mutation ((trinary/211' code input0 input1 input2)))])
+(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
{}
@@ -398,17 +441,21 @@
<inputs>')
<locals>' (template.splice <locals>)]
- (def: #export (<name> <input-names>)
- (-> <input-types> Bytecode)
- (..bytecode
- (`` ($_ /@compose
- (/.consumes <consumes>)
- (/.produces <produces>)
- (~~ (template [<local>]
- [(/.has-local <local>)]
-
- <locals>'))))
- (`` (<arity> (hex <code>) (~~ (template.splice <arity-inputs>)))))))]
+ (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>'
))]
@@ -482,116 +529,129 @@
[["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: #export (tableswitch minimum default cases)
- (-> S4 Big-Jump (List Big-Jump) Bytecode)
- (let [append (: (-> Specification Specification)
- (function (_ [size mutation])
- (let [default-offset (n.+ ..code-size size)
- padding (n.% 4
- (n.- (n.% 4 default-offset)
- 4))
- amount-of-cases (list.size cases)
- maximum (|> amount-of-cases .int ///signed.s4 (///signed.s4/+ minimum))
- tableswitch-size ($_ n.+
- ..code-size
- padding
- ..big-jump-size
- ..integer-size
- ..integer-size
- (n.* amount-of-cases ..big-jump-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)
- append)))
-
-(def: #export (lookupswitch default cases)
- (-> Big-Jump (List [S4 Big-Jump]) Bytecode)
- (let [append (: (-> Specification Specification)
- (function (_ [size mutation])
- (let [default-offset (n.+ ..code-size size)
- padding (n.% 4
- (n.- (n.% 4 default-offset)
- 4))
- amount-of-cases (list.size cases)
- case-size (n.+ ..integer-size ..big-jump-size)
- lookupswitch-size ($_ n.+
- ..code-size
- padding
- ..big-jump-size
- ..integer-size
- (n.* amount-of-cases case-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)
- append)))
+(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 ..nop)
+ (def: identity ..no-bytecode)
(def: (compose left right)
(function (_ input)
diff --git a/stdlib/source/lux/target/jvm/instruction/condition.lux b/stdlib/source/lux/target/jvm/instruction/condition.lux
index 82c709800..50061b579 100644
--- a/stdlib/source/lux/target/jvm/instruction/condition.lux
+++ b/stdlib/source/lux/target/jvm/instruction/condition.lux
@@ -20,9 +20,11 @@
[encoding
["#." unsigned (#+ U1 U2)]]]])
+(type: #export Stack U2)
+
(type: #export Environment
{#resources Resources
- #stack U2})
+ #stack Stack})
(def: #export start
Environment
diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux
index cb7324316..af2d07de7 100644
--- a/stdlib/source/lux/target/jvm/method.lux
+++ b/stdlib/source/lux/target/jvm/method.lux
@@ -59,20 +59,20 @@
@descriptor (//constant/pool.descriptor (//type.descriptor type))
attributes (monad.seq @ attributes)
?code (//instruction.resolve code)
- [environment bytecode] (case (do try.monad
- [[bytecode output] ?code
- [environment specification] (//instruction/bytecode.run bytecode)]
- (wrap [environment (binaryF.instance specification)]))
- (#try.Success [environment bytecode])
- (wrap [environment bytecode])
-
- (#try.Failure error)
- ## TODO: Allow error-management within
- ## the monad.
- (undefined))
+ [environment exceptions bytecode] (case (do try.monad
+ [[bytecode exceptions output] ?code
+ [environment specification] (//instruction/bytecode.run bytecode)]
+ (wrap [environment exceptions (binaryF.instance specification)]))
+ (#try.Success [environment exceptions bytecode])
+ (wrap [environment exceptions bytecode])
+
+ (#try.Failure error)
+ ## TODO: Allow error-management within
+ ## the monad.
+ (error! error))
@code (//attribute.code {#//attribute/code.resources (get@ #//instruction/condition.resources environment)
#//attribute/code.code bytecode
- #//attribute/code.exception-table (row.row)
+ #//attribute/code.exception-table exceptions
#//attribute/code.attributes (row.row)})]
(wrap {#modifier modifier
#name @name
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
index 3240288f7..a56629158 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
@@ -17,6 +17,7 @@
[encoding
["." unsigned]]]]]
["." // #_
+ ["#." type]
["#." runtime (#+ Operation Phase)]
["#." value]
[////
@@ -25,13 +26,11 @@
["." phase ("operation@." monad)
["." generation]]]])
-(def: $Object (type.class "java.lang.Object" (list)))
-
(def: equals-name
"equals")
(def: equals-type
- (type.method [(list //value.type) type.boolean (list)]))
+ (type.method [(list //type.value) type.boolean (list)]))
(def: (pop-alt stack-depth)
(-> Nat (Instruction Any))
@@ -60,15 +59,13 @@
(Instruction Any)
($_ _.compose
_.dup
- (..ldc/integer 0)
- _.aaload))
+ (//runtime.get //runtime.stack-head)))
(def: pop
(Instruction Any)
($_ _.compose
- (..ldc/integer 1)
- _.aaload
- (_.checkcast //runtime.$Stack)))
+ (//runtime.get //runtime.stack-tail)
+ (_.checkcast //type.stack)))
(def: (path' phase stack-depth @else @end path)
(-> Phase Nat Label Label Path (Operation (Instruction Any)))
@@ -108,7 +105,7 @@
(operation@wrap ($_ _.compose
..peek
(_.ldc/string value)
- (_.invokevirtual ..$Object ..equals-name ..equals-type)
+ (_.invokevirtual //type.text ..equals-name ..equals-type)
(_.ifeq @else)))
(#synthesis.Then bodyS)
@@ -127,7 +124,7 @@
@fail _.new-label]
($_ _.compose
..peek
- (_.checkcast //runtime.$Variant)
+ (_.checkcast //type.variant)
(..ldc/integer (<prepare> idx))
<flag>
//runtime.case
@@ -151,7 +148,7 @@
//runtime.left-projection)]
($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
optimized-projection
//runtime.push)))
@@ -159,7 +156,7 @@
(^ (synthesis.member/right lefts))
(operation@wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
//runtime.right-projection
//runtime.push))
@@ -172,8 +169,8 @@
[thenG (path' phase stack-depth @else @end thenP)]
(wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
- (..ldc/integer 0)
+ (_.checkcast //type.tuple)
+ _.iconst-0
_.aaload
(_.astore (unsigned.u1 register))
thenG)))
@@ -187,7 +184,7 @@
[then! (path' phase stack-depth @else @end thenP)]
(wrap ($_ _.compose
..peek
- (_.checkcast //runtime.$Tuple)
+ (_.checkcast //type.tuple)
(..ldc/integer lefts)
<projection>
(_.astore (unsigned.u1 register))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux
index 8759bf2e8..d8ac81cc4 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux
@@ -93,8 +93,6 @@
(_.set-label @end)
)))
-(def: unit (_.ldc/string //////synthesis.unit))
-
## TODO: Get rid of this ASAP
(def: lux::syntax-char-case!
(..custom [($_ <>.and
@@ -190,15 +188,11 @@
(#static MIN_VALUE java/lang/Double)
(#static MAX_VALUE java/lang/Double))
-(def: ldc/double
- (-> Frac (Instruction Any))
- (|>> constant.double _.ldc/double))
-
(template [<name> <const>]
[(def: (<name> _)
(Nullary (Instruction Any))
($_ _.compose
- (..ldc/double <const>)
+ (_.ldc/double (constant.double <const>))
(///value.wrap type.double)))]
[f64::smallest (java/lang/Double::MIN_VALUE)]
@@ -227,10 +221,6 @@
[f64::% type.double _.drem]
)
-(def: ldc/integer
- (-> (I64 Any) (Instruction Any))
- (|>> .i64 i32.i32 constant.integer _.ldc/integer))
-
(template [<eq> <lt> <type> <cmp>]
[(template [<name> <reference>]
[(def: (<name> [paramG subjectG])
@@ -239,11 +229,11 @@
subjectG (///value.unwrap <type>)
paramG (///value.unwrap <type>)
<cmp>
- (..ldc/integer <reference>)
+ <reference>
(..predicate _.if-icmpeq)))]
- [<eq> +0]
- [<lt> -1])]
+ [<eq> _.iconst-0]
+ [<lt> _.iconst-m1])]
[i64::= i64::< type.long _.lcmp]
[f64::= f64::< type.double _.dcmpg]
@@ -383,7 +373,7 @@
startG ..jvm-int
(_.invokevirtual ..$String "indexOf" index-method)
_.dup
- (ldc/integer -1)
+ _.iconst-m1
(_.if-icmpeq @not-found)
..lux-int
///runtime.some-injection
@@ -413,7 +403,7 @@
messageG
..ensure-string
(_.invokevirtual ..$PrintStream "println" ..string-method)
- ..unit))
+ ///runtime.unit))
(def: (io::error messageG)
(Unary (Instruction Any))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
index a0292ccc3..6a66f78f8 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
@@ -71,7 +71,7 @@
list.indices
(list@map (|>> inc (/apply.method classT environment arity @begin body)))
(list& (/implementation.method arity @begin body)))
- (list (/implementation.method' /apply.name arity @begin body)))))]
+ (list (/implementation.method' //runtime.apply::name arity @begin body)))))]
(do phase.monad
[instance (/new.instance classT environment arity)]
(wrap [fields methods instance]))))
@@ -124,6 +124,6 @@
($_ _.compose
(_.checkcast /abstract.class)
(monad.seq _.monad batchG)
- (_.invokevirtual /abstract.class /apply.name (/apply.type (list.size batchG)))
+ (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG)))
))))
))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
index 9b653ec6c..419fca601 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
@@ -1,7 +1,16 @@
(.module:
- [lux #*
+ [lux (#- Type)
[target
[jvm
- ["." type]]]])
+ ["." type (#+ Type)
+ [category (#+ Method)]]]]]
+ [//
+ [field
+ [constant
+ ["." arity]]]])
(def: #export class (type.class "LuxFunction" (list)))
+
+(def: #export init
+ (Type Method)
+ (type.method [(list arity.type) type.void (list)]))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
index 083d279ea..cbff8ea5e 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
@@ -16,12 +16,12 @@
[constant
[pool (#+ Pool)]]]]]
["." //// #_
- ["#." value]
+ ["#." type]
["#." reference]
[////
[reference (#+ Register)]]])
-(def: #export type ////value.type)
+(def: #export type ////type.value)
(def: #export (get class name)
(-> (Type Class) Text (Instruction Any))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux
index b646ddbf6..4806e3ba1 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux
@@ -8,9 +8,7 @@
["." unsigned]]
["." type]]]]
["." ///// #_
- ["#." abstract]
- ["/#" // #_
- ["#." reference]]])
+ ["#." abstract]])
(def: #export field "partials")
(def: #export type type.int)
@@ -19,9 +17,12 @@
(Instruction Any)
(_.bipush (unsigned.u1 0)))
+(def: this
+ _.aload-0)
+
(def: #export value
(Instruction Any)
($_ _.compose
- //////reference.this
+ ..this
(_.getfield /////abstract.class ..field ..type)
))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
index 0d4e1f2b3..e25889a37 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
@@ -44,14 +44,6 @@
[arity (#+ Arity)]
["." reference (#+ Register)]]]]])
-(def: #export name "apply")
-
-(def: #export (type arity)
- (-> Arity (Type category.Method))
- (type.method [(list.repeat arity ////value.type)
- ////value.type
- (list)]))
-
(def: (increment by)
(-> Nat (Instruction Any))
($_ _.compose
@@ -73,7 +65,7 @@
($_ _.compose
(_.checkcast ///abstract.class)
(..inputs offset arity)
- (_.invokevirtual ///abstract.class ..name (..type arity))
+ (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity))
(if (n.> ///arity.maximum amount)
(apply (n.+ ///arity.maximum offset)
(n.- ///arity.maximum amount))
@@ -91,8 +83,8 @@
////runtime.apply-failure
_.aconst-null
_.areturn)]
- (method.method //.modifier ..name
- (..type apply-arity)
+ (method.method //.modifier ////runtime.apply::name
+ (////runtime.apply::type apply-arity)
(list)
(do _.monad
[@default _.new-label
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
index 8643dc916..f7a3edb93 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
@@ -15,7 +15,7 @@
["." category]]]]]
["." //
["//#" /// #_
- ["#." value]
+ ["#." type]
[////
[arity (#+ Arity)]]]])
@@ -23,8 +23,8 @@
(def: #export (type arity)
(-> Arity (Type category.Method))
- (type.method [(list.repeat arity ////value.type)
- ////value.type
+ (type.method [(list.repeat arity ////type.value)
+ ////type.value
(list)]))
(def: #export (method' name arity @begin body)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
index 5eddafb8a..691c4df70 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
@@ -30,7 +30,7 @@
["#." foreign]
["#." partial]]]
["/#" // #_
- ["#." value]
+ ["#." type]
["#." reference]
[////
[reference (#+ Register)]
@@ -41,7 +41,7 @@
(def: (partials arity)
(-> Arity (List (Type Value)))
- (list.repeat arity ////value.type))
+ (list.repeat arity ////type.value))
(def: #export (type environment arity)
(-> Environment Arity (Type category.Method))
@@ -52,10 +52,6 @@
type.void
(list)]))
-(def: super-type
- (Type category.Method)
- (type.method [(list ///arity.type) type.void (list)]))
-
(def: #export (super environment-size arity)
(-> Nat Arity (Instruction Any))
(let [arity-register (inc environment-size)]
@@ -63,7 +59,7 @@
(if (arity.unary? arity)
(_.bipush (unsigned.u1 0))
(_.iload (unsigned.u1 arity-register)))
- (_.invokespecial ///abstract.class ..name ..super-type))))
+ (_.invokespecial ///abstract.class ..name ///abstract.init))))
(def: (store-all amount put offset)
(-> Nat
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
index 9e60e6cda..6c9a963d7 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
@@ -18,7 +18,8 @@
["." unsigned]]]]]
["." // #_
[runtime (#+ Operation)]
- ["#." value]])
+ ["#." value]
+ ["#." type]])
(def: local
(-> Register (Instruction Any))
@@ -26,7 +27,7 @@
(def: #export this
(Instruction Any)
- (..local 0))
+ _.aload-0)
(template [<name> <prefix>]
[(def: #export <name>
@@ -45,7 +46,7 @@
..this
(_.getfield (type.class function-class (list))
(..foreign-name variable)
- //value.type)))))
+ //type.value)))))
(def: #export (variable variable)
(-> Variable (Operation (Instruction Any)))
@@ -60,4 +61,4 @@
(-> Name (Operation (Instruction Any)))
(do phase.monad
[bytecode-name (generation.remember name)]
- (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //value.type))))
+ (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
index 3868b747f..a47892039 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
@@ -1,27 +1,53 @@
(.module:
- [lux (#- Type Definition case)
+ [lux (#- Type Definition case log! false true)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [state (#+ State)]]
[data
[binary (#+ Binary)]
[number
["." i32]
["." i64]
- ["n" nat]]]
+ ["n" nat]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]
+ [format
+ [".F" binary]]]
[target
[jvm
["_" instruction (#+ Label Instruction)]
- ["." constant]
+ ["." modifier (#+ Modifier) ("#@." monoid)]
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["." version]
+ ["." class (#+ Class)]
+ ["." constant
+ [pool (#+ Pool)]]
+ [encoding
+ ["." unsigned]
+ ["." name]]
["." type (#+ Type)
- ["." category (#+ Method)]]]]]
+ ["." category (#+ Return' Value')]
+ ["." reflection]]]]]
["." // #_
+ ["#." type]
["#." value]
["#." function #_
- ["#" abstract]]
+ ["#" abstract]
+ [field
+ [constant
+ ["#/." arity]]
+ [variable
+ [partial
+ ["#/." count]]]]]
["/#" //
["/#" //
[//
+ [arity (#+ Arity)]
[reference (#+ Register)]
- ["." synthesis]]]]]
- )
+ ["." synthesis]]]]])
(type: #export Byte-Code Binary)
@@ -44,83 +70,76 @@
(def: #export class (type.class "LuxRuntime" (list)))
-(def: $Text (type.class "java.lang.String" (list)))
-
-(def: #export $Tag type.int)
-(def: #export $Flag //value.type)
-(def: #export $Variant (type.array //value.type))
-
-(def: #export $Offset type.int)
-(def: #export $Tuple (type.array //value.type))
-
-(def: #export $Stack (type.array //value.type))
-
(def: procedure
- (-> Text (Type Method) (Instruction Any))
+ (-> Text (Type category.Method) (Instruction Any))
(_.invokestatic ..class))
-(def: failure-type
- (type.method [(list) type.void (list)]))
-
-(def: #export apply-failure
- (..procedure "apply_failure" ..failure-type))
-
-(def: #export pm-failure
- (..procedure "pm_failure" ..failure-type))
-
-(def: push-name
- "push")
-
-(def: push-type
- (type.method [(list ..$Stack //value.type) ..$Stack (list)]))
-
-(def: #export push
- (..procedure ..push-name ..push-type))
-
-(def: case-name
- "case")
-
-(def: case-type
- (type.method [(list ..$Variant ..$Tag ..$Flag) //value.type (list)]))
+(def: modifier
+ (Modifier Method)
+ ($_ modifier@compose
+ method.public
+ method.static
+ method.strict
+ ))
-(def: #export case
- (..procedure ..case-name ..case-type))
+(def: local
+ (-> Nat (Instruction Any))
+ (|>> unsigned.u1 _.aload))
-(def: projection-type
- (type.method [(list ..$Tuple $Offset) //value.type (list)]))
-
-(def: #export left-projection
- (..procedure "left" ..projection-type))
-
-(def: #export right-projection
- (..procedure "right" ..projection-type))
-
-(def: try-name
- "try")
-
-(def: try-type
- (type.method [(list //function.class) ..$Variant (list)]))
-
-(def: #export try
- (_.invokestatic ..class ..try-name ..try-type))
-
-(def: #export decode-frac
- (..procedure "decode_frac" (type.method [(list ..$Text) ..$Variant (list)])))
+(def: this
+ (Instruction Any)
+ _.aload-0)
-(def: #export variant
- (..procedure "variant" (type.method [(list ..$Tag ..$Flag //value.type) ..$Variant (list)])))
+(def: #export (get index)
+ (-> (Instruction Any) (Instruction Any))
+ ($_ _.compose
+ index
+ _.aaload))
-(def: ldc/integer
- (-> (I64 Any) (Instruction Any))
- (|>> .i64 i32.i32 constant.integer _.ldc/integer))
+(def: (set! index value)
+ (-> (Instruction Any) (Instruction Any) (Instruction Any))
+ ($_ _.compose
+ _.dup
+ index
+ value
+ _.aastore))
+
+(def: #export unit (_.ldc/string synthesis.unit))
+
+(def: variant::name "variant")
+(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)]))
+(def: #export variant (..procedure ..variant::name ..variant::type))
+
+(def: variant-tag _.iconst-0)
+(def: variant-last? _.iconst-1)
+(def: variant-value _.iconst-2)
+
+(def: variant::method
+ (let [new-variant ($_ _.compose
+ _.iconst-3
+ (_.anewarray //type.value))
+ $tag ($_ _.compose
+ _.iload-0
+ (//value.wrap type.int))
+ $last? _.aload-1
+ $value _.aload-2]
+ (method.method ..modifier ..variant::name
+ ..variant::type
+ (list)
+ ($_ _.compose
+ new-variant
+ (..set! ..variant-tag $tag)
+ (..set! ..variant-last? $last?)
+ (..set! ..variant-value $value)
+ _.areturn))))
(def: #export left-flag _.aconst-null)
-(def: #export right-flag (_.ldc/string ""))
+(def: #export right-flag ..unit)
(def: #export left-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +0)
+ _.iconst-0
..left-flag
_.dup2-x1
_.pop2
@@ -129,25 +148,448 @@
(def: #export right-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +1)
+ _.iconst-1
..right-flag
_.dup2-x1
_.pop2
..variant))
-(def: #export some-injection right-injection)
+(def: #export some-injection ..right-injection)
(def: #export none-injection
(Instruction Any)
($_ _.compose
- (..ldc/integer +0)
+ _.iconst-0
_.aconst-null
- (_.ldc/string synthesis.unit)
+ ..unit
..variant))
+(def: (risky $unsafe)
+ (-> (Instruction Any) (Instruction Any))
+ (do _.monad
+ [@from _.new-label
+ @to _.new-label
+ @handler _.new-label]
+ ($_ _.compose
+ (_.try @from @to @handler //type.error)
+ (_.set-label @from)
+ $unsafe
+ ..some-injection
+ _.areturn
+ (_.set-label @to)
+ (_.set-label @handler)
+ ..none-injection
+ _.areturn)))
+
+(def: decode-frac::name "decode_frac")
+(def: decode-frac::type (type.method [(list //type.text) //type.variant (list)]))
+(def: #export decode-frac (..procedure ..decode-frac::name ..decode-frac::type))
+
+(def: decode-frac::method
+ (method.method ..modifier ..variant::name
+ ..variant::type
+ (list)
+ (..risky
+ ($_ _.compose
+ ..this
+ (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)]))
+ (//value.wrap type.double)))))
+
+(def: #export log!
+ (Instruction Any)
+ (let [^PrintStream (type.class "java.io.PrintStream" (list))
+ ^System (type.class "java.lang.System" (list))
+ out (_.getstatic ^System "out" ^PrintStream)
+ print-type (type.method [(list //type.value) type.void (list)])
+ print! (function (_ method) (_.invokevirtual ^PrintStream method print-type))]
+ ($_ _.compose
+ out (_.ldc/string "LOG: ") (print! "print")
+ out _.swap (print! "println"))))
+
+(def: exception-constructor (type.method [(list //type.text) type.void (list)]))
+(def: (illegal-state-exception message)
+ (-> Text (Instruction Any))
+ (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
+ ($_ _.compose
+ (_.new ^IllegalStateException)
+ _.dup
+ (_.ldc/string message)
+ (_.invokespecial ^IllegalStateException "<init>" ..exception-constructor))))
+
+(def: failure::type
+ (type.method [(list) type.void (list)]))
+
+(def: (failure name message)
+ (-> Text Text (State Pool Method))
+ (method.method ..modifier name
+ ..failure::type
+ (list)
+ ($_ _.compose
+ (..illegal-state-exception message)
+ _.athrow)))
+
+(def: apply-failure::name "apply_failure")
+(def: #export apply-failure (..procedure ..apply-failure::name ..failure::type))
+
+(def: apply-failure::method
+ (..failure ..apply-failure::name "Error while applying function."))
+
+(def: pm-failure::name "pm_failure")
+(def: #export pm-failure (..procedure ..pm-failure::name ..failure::type))
+
+(def: pm-failure::method
+ (..failure ..pm-failure::name "Invalid expression for pattern-matching."))
+
+(def: #export stack-head _.iconst-0)
+(def: #export stack-tail _.iconst-1)
+
+(def: push::name "push")
+(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)]))
+(def: #export push (..procedure ..push::name ..push::type))
+
+(def: push::method
+ (method.method ..modifier ..push::name
+ ..push::type
+ (list)
+ (let [new-stack-frame! ($_ _.compose
+ _.iconst-2
+ (_.anewarray //type.value))
+ $head _.aload-1
+ $tail _.aload-0]
+ ($_ _.compose
+ new-stack-frame!
+ (..set! ..stack-head $head)
+ (..set! ..stack-tail $tail)
+ _.areturn))))
+
+(def: case::name "case")
+(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)]))
+(def: #export case (..procedure ..case::name ..case::type))
+
+(def: case::method
+ (method.method ..modifier ..case::name ..case::type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @perfect-match! _.new-label
+ @tags-match! _.new-label
+ @maybe-nested _.new-label
+ @maybe-super-nested _.new-label
+ @mismatch! _.new-label
+ #let [::tag ($_ _.compose
+ (..get ..variant-tag)
+ (//value.unwrap type.int))
+ ::last? (..get ..variant-last?)
+ ::value (..get ..variant-value)
+
+ $variant _.aload-0
+ $tag _.iload-1
+ $last? _.aload-2
+
+ not-found _.aconst-null
+
+ update-$tag ($_ _.compose
+ _.isub
+ _.istore-1)
+ update-$variant ($_ _.compose
+ $variant ::value
+ (_.checkcast //type.variant)
+ _.astore-0)
+ recur (: (-> Label (Instruction Any))
+ (function (_ @loop-start)
+ ($_ _.compose
+ update-$tag
+ update-$variant
+ (_.goto @loop-start))))
+
+ super-nested-tag ($_ _.compose
+ $variant ::tag
+ $tag _.isub)
+ super-nested ($_ _.compose
+ super-nested-tag
+ $variant ::last?
+ $variant ::value
+ ..variant)]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $tag
+ $variant ::tag
+ _.dup2 (_.if-icmpeq @tags-match!)
+ _.dup2 (_.if-icmpgt @maybe-nested)
+ _.dup2 (_.if-icmplt @maybe-super-nested)
+ ## _.pop2
+ not-found
+ _.areturn
+ (_.set-label @tags-match!) ## tag, sumT
+ $last? ## tag, sumT, wants-last?
+ $variant ::last? ## tag, sumT, wants-last?, is-last?
+ (_.if-acmpeq @perfect-match!) ## tag, sumT
+ (_.set-label @maybe-nested) ## tag, sumT
+ $variant ::last? ## tag, sumT, last?
+ (_.ifnull @mismatch!) ## tag, sumT
+ (recur @loop)
+ (_.set-label @perfect-match!) ## tag, sumT
+ ## _.pop2
+ $variant ::value
+ _.areturn
+ (_.set-label @maybe-super-nested) ## tag, sumT
+ $last? (_.ifnull @mismatch!)
+ ## _.pop2
+ super-nested
+ _.areturn
+ (_.set-label @mismatch!) ## tag, sumT
+ ## _.pop2
+ not-found
+ _.areturn
+ ))))
+
+(def: projection-type (type.method [(list //type.tuple //type.offset) //type.value (list)]))
+
+(def: left-projection::name "left")
+(def: #export left-projection (..procedure ..left-projection::name ..projection-type))
+
+(def: right-projection::name "right")
+(def: #export right-projection (..procedure ..right-projection::name ..projection-type))
+
+(def: projection::method2
+ [(State Pool Method) (State Pool Method)]
+ (let [$tuple _.aload-0
+ $tuple::size ($_ _.compose
+ $tuple _.arraylength)
+
+ $lefts _.iload-1
+
+ $last-right ($_ _.compose
+ $tuple::size _.iconst-1 _.isub)
+
+ update-$lefts ($_ _.compose
+ $lefts $last-right _.isub
+ _.istore-1)
+ update-$tuple ($_ _.compose
+ $tuple $last-right _.aaload (_.checkcast //type.tuple)
+ _.astore-0)
+ recur (: (-> Label (Instruction Any))
+ (function (_ @loop)
+ ($_ _.compose
+ update-$lefts
+ update-$tuple
+ (_.goto @loop))))
+
+ left-projection::method
+ (method.method ..modifier ..left-projection::name ..projection-type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @recursive _.new-label
+ #let [::left ($_ _.compose
+ $lefts _.aaload)]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $lefts $last-right (_.if-icmpge @recursive)
+ $tuple ::left
+ _.areturn
+ (_.set-label @recursive)
+ ## Recursive
+ (recur @loop))))
+
+ right-projection::method
+ (method.method ..modifier ..right-projection::name ..projection-type
+ (list)
+ (do _.monad
+ [@loop _.new-label
+ @not-tail _.new-label
+ @slice _.new-label
+ #let [$right ($_ _.compose
+ $lefts
+ _.iconst-1
+ _.iadd)
+ $::nested ($_ _.compose
+ $tuple _.swap _.aaload)
+ super-nested ($_ _.compose
+ $tuple
+ $right
+ $tuple::size
+ (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange"
+ (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]]
+ ($_ _.compose
+ (_.set-label @loop)
+ $last-right $right
+ _.dup2 (_.if-icmpne @not-tail)
+ ## _.pop
+ $::nested
+ _.areturn
+ (_.set-label @not-tail)
+ (_.if-icmpgt @slice)
+ ## Must recurse
+ (recur @loop)
+ (_.set-label @slice)
+ super-nested
+ _.areturn)))]
+ [left-projection::method
+ right-projection::method]))
+
+(def: #export apply::name "apply")
+
+(def: #export (apply::type arity)
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity //type.value) //type.value (list)]))
+
+(def: #export apply
+ (_.invokevirtual //function.class ..apply::name (..apply::type 1)))
+
+(def: try::name "try")
+(def: try::type (type.method [(list //function.class) //type.variant (list)]))
+(def: #export try (..procedure ..try::name ..try::type))
+
+(def: false _.iconst-0)
+(def: true _.iconst-1)
+
+(def: try::method
+ (method.method ..modifier ..try::name ..try::type
+ (list)
+ (do _.monad
+ [@from _.new-label
+ @to _.new-label
+ @handler _.new-label
+ #let [$unsafe ..this
+ unit _.aconst-null
+
+ ^StringWriter (type.class "java.io.StringWriter" (list))
+ string-writer ($_ _.compose
+ (_.new ^StringWriter)
+ _.dup
+ (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)])))
+
+ ^PrintWriter (type.class "java.io.PrintWriter" (list))
+ print-writer ($_ _.compose
+ ## WTW
+ (_.new ^PrintWriter) ## WTWP
+ _.dup-x1 ## WTPWP
+ _.swap ## WTPPW
+ ..true ## WTPPWZ
+ (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
+ ## WTP
+ )]]
+ ($_ _.compose
+ (_.try @from @to @handler //type.error)
+ (_.set-label @from)
+ $unsafe unit ..apply
+ ..right-injection _.areturn
+ (_.set-label @to)
+ (_.set-label @handler) ## T
+ string-writer ## TW
+ _.dup-x1 ## WTW
+ print-writer ## WTP
+ (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W
+ (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S
+ ..left-injection _.areturn
+ ))))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(def: #export ^Object (type.class "java.lang.Object" (list)))
+
+(def: translate-runtime
+ (Operation Any)
+ (let [class (..reflection ..class)
+ modifier (: (Modifier Class)
+ ($_ modifier@compose
+ class.public
+ class.final))
+ bytecode (<| (binaryF.run class.writer)
+ (class.class version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ^Object)) (list)
+ (list)
+ (let [[left-projection::method right-projection::method] projection::method2]
+ (list ..decode-frac::method
+ ..variant::method
+
+ ..apply-failure::method
+ ..pm-failure::method
+
+ ..push::method
+ ..case::method
+ left-projection::method
+ right-projection::method
+
+ ..try::method))
+ (row.row)))]
+ (do ////.monad
+ [_ (///.execute! class [class bytecode])]
+ (///.save! .false ["" class] [class bytecode]))))
+
+(def: translate-function
+ (Operation Any)
+ (let [apply::method+ (|> (list.n/range (inc //function/arity.minimum)
+ //function/arity.maximum)
+ (list@map (function (_ arity)
+ (method.method method.public ..apply::name (..apply::type arity)
+ (list)
+ (let [previous-inputs (|> arity
+ list.indices
+ (monad.map _.monad ..local))]
+ ($_ _.compose
+ previous-inputs
+ (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity)))
+ (_.checkcast //function.class)
+ (..local arity)
+ (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum))
+ _.areturn)))))
+ (list& (method.method (modifier@compose method.public method.abstract)
+ ..apply::name (..apply::type //function/arity.minimum)
+ (list)
+ ## TODO: It shouldn't be necessary to set the code for this method, since it's abstract.
+ ## Setting this might be a bug. Verify & fix ASAP.
+ ($_ _.compose
+ ..apply-failure
+ ..this
+ _.areturn))))
+ <init>::method (method.method method.public "<init>" //function.init
+ (list)
+ (let [$partials _.iload-1]
+ ($_ _.compose
+ ..this
+ (_.invokespecial ..^Object "<init>" (type.method [(list) type.void (list)]))
+ ..this
+ $partials
+ (_.putfield //function.class //function/count.field //function/count.type)
+ _.return)))
+ modifier (: (Modifier Class)
+ ($_ modifier@compose
+ class.public
+ class.abstract))
+ class (..reflection //function.class)
+ partial-count (: (State Pool Field)
+ (field.field (modifier@compose field.public field.final)
+ //function/count.field
+ //function/count.type
+ (row.row)))
+ bytecode (<| (binaryF.run class.writer)
+ (class.class version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ..^Object)) (list)
+ (list partial-count)
+ (list& <init>::method apply::method+)
+ (row.row)))]
+ (do ////.monad
+ [_ (///.execute! class [class bytecode])]
+ (///.save! .false ["" class] [class bytecode]))))
+
+(def: #export translate
+ (Operation Any)
+ (do ////.monad
+ [_ ..translate-runtime]
+ ..translate-function))
+
(def: #export forge-label
(Operation Label)
- (let [shift (n./ 2 i64.width)]
+ (let [shift (n./ 4 i64.width)]
## This shift is done to avoid the possibility of forged labels
## to be in the range of the labels that are generated automatically
## during the evaluation of Instruction expressions.
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux
new file mode 100644
index 000000000..954740d2d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux
@@ -0,0 +1,22 @@
+(.module:
+ [lux #*
+ [target
+ [jvm
+ ["." type]]]])
+
+(def: #export frac (type.class "java.lang.Double" (list)))
+(def: #export text (type.class "java.lang.String" (list)))
+
+(def: #export value (type.class "java.lang.Object" (list)))
+
+(def: #export tag type.int)
+(def: #export flag ..value)
+(def: #export variant (type.array ..value))
+
+(def: #export offset type.int)
+(def: #export index ..offset)
+(def: #export tuple (type.array ..value))
+
+(def: #export stack (type.array ..value))
+
+(def: #export error (type.class "java.lang.Throwable" (list)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
index 803ac2522..e6deaf205 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
@@ -9,8 +9,6 @@
(def: #export field "value")
-(def: #export type (type.class "java.lang.Object" (list)))
-
(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
[(def: (<name> type)
(-> (Type Primitive) Text)