diff options
Diffstat (limited to '')
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) |