diff options
Diffstat (limited to '')
14 files changed, 563 insertions, 564 deletions
diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux index 44b3b1b5b..61c19ccfa 100644 --- a/stdlib/source/lux/target/jvm/attribute/code.lux +++ b/stdlib/source/lux/target/jvm/attribute/code.lux @@ -10,7 +10,7 @@ [collection ["." row (#+ Row) ("#@." functor fold)]]]] ["." /// #_ - [program + [instruction ["#." resources (#+ Resources)]] [encoding ["#." unsigned (#+ U2)]]] diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux index 003bad74f..b291baf3e 100644 --- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux +++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux @@ -9,7 +9,7 @@ ["//#" /// #_ [constant (#+ Class)] ["#." index (#+ Index)] - [program + [instruction ["#." jump (#+ Jump)]] [encoding ["#." unsigned (#+ U2)]]]]) diff --git a/stdlib/source/lux/target/jvm/attribute/constant.lux b/stdlib/source/lux/target/jvm/attribute/constant.lux index 4dae93140..dd8c7c395 100644 --- a/stdlib/source/lux/target/jvm/attribute/constant.lux +++ b/stdlib/source/lux/target/jvm/attribute/constant.lux @@ -7,9 +7,9 @@ [binary (#+ Writer)]]]] ["." /// #_ [constant (#+ Value)] + ["#." index (#+ Index)] [encoding - ["#." unsigned (#+ U2 U4)]] - ["#." index (#+ Index)]]) + ["#." unsigned (#+ U2 U4)]]]) (type: #export Constant (Index (Value Any))) diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux new file mode 100644 index 000000000..8ae42752f --- /dev/null +++ b/stdlib/source/lux/target/jvm/instruction.lux @@ -0,0 +1,523 @@ +(.module: + [lux #* + [abstract + [monoid (#+ Monoid)] + [monad (#+ Monad do)]] + [control + ["." state (#+ State)] + ["." writer (#+ Writer)] + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + [number + ["." nat]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary (#+ Dictionary)]]]] + ["." / #_ + ["#." condition (#+ Local)] + ["#." jump (#+ Jump Big-Jump)] + ["#." bytecode (#+ Primitive-Array-Type Bytecode) ("#@." monoid)] + ["/#" // #_ + ["#." index] + ["#." descriptor (#+ Descriptor Value Return Field)] + [encoding + ["#." name (#+ External)] + ["#." unsigned (#+ U1 U2)] + ["#." signed]] + ["#." constant (#+ UTF8) + ["#/."pool (#+ Pool)]]]]) + +(type: #export Label Nat) + +(type: #export Address Nat) + +(type: Resolver (Dictionary Label Address)) + +(type: Tracker + {#program-counter Address + #next-label Label + #known-labels Resolver}) + +(def: fresh + Tracker + {#program-counter 0 + #next-label 0 + #known-labels (dictionary.new nat.hash)}) + +(type: #export Partial + (-> Resolver (Try Bytecode))) + +(def: partial-identity + Partial + (function.constant (#try.Success /bytecode.nop))) + +(structure: partial-monoid + (Monoid Partial) + + (def: identity ..partial-identity) + + (def: (compose left right) + (cond (is? ..partial-identity left) + right + + (is? ..partial-identity right) + left + + ## else + (function (_ resolver) + (do try.monad + [left (left resolver) + right (right resolver)] + (wrap (/bytecode@compose left right))))))) + +(type: #export (Instruction a) + (State [Pool Tracker] (Writer Partial a))) + +(def: #export new-label + (Instruction Label) + (function (_ [pool tracker]) + [[pool + (update@ #next-label inc tracker)] + [..partial-identity + (get@ #next-label tracker)]])) + +(def: #export (set-label label) + (-> Label (Instruction Any)) + (function (_ [pool tracker]) + [[pool + (update@ #known-labels + (dictionary.put label (get@ #program-counter tracker)) + tracker)] + [..partial-identity + []]])) + +(def: #export monad + ## TODO: Remove the coercion. It was added because the type-checker + ## seems to have a bug that is being triggered here. + (:coerce (Monad Instruction) + (writer.with ..partial-monoid + (: (Monad (State [Pool Tracker])) + state.monad)))) + +(def: #export (resolve instruction) + (All [a] (-> (Instruction a) (State Pool (Try [Bytecode 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]))]))) + +(def: (nullary bytecode) + (-> Bytecode (Instruction Any)) + (function (_ [pool tracker]) + [[pool tracker] + [(function.constant (#try.Success bytecode)) + []]])) + +(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] + + [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] + + [dconst-0 /bytecode.dconst-0] + [dconst-1 /bytecode.dconst-1] + + [pop /bytecode.pop] + [pop2 /bytecode.pop2] + + [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 /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] + + [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] + + [fadd /bytecode.fadd] + [fsub /bytecode.fsub] + [fmul /bytecode.fmul] + [fdiv /bytecode.fdiv] + [frem /bytecode.frem] + [fneg /bytecode.fneg] + + [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] + + [f2i /bytecode.f2i] + [f2l /bytecode.f2l] + [f2d /bytecode.f2d] + + [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] + + [fcmpl /bytecode.fcmpl] + [fcmpg /bytecode.fcmpg] + + [dcmpl /bytecode.dcmpl] + [dcmpg /bytecode.dcmpg] + + [ireturn /bytecode.ireturn] + [lreturn /bytecode.lreturn] + [freturn /bytecode.freturn] + [dreturn /bytecode.dreturn] + [areturn /bytecode.areturn] + [return /bytecode.return] + + [arraylength /bytecode.arraylength] + + [athrow /bytecode.athrow] + + [monitorenter /bytecode.monitorenter] + [monitorexit /bytecode.monitorexit] + ) + +(def: #export (bipush byte) + (-> U1 (Instruction Any)) + (function (_ [pool tracker]) + [[pool tracker] + [(function.constant (#try.Success (/bytecode.bipush byte))) + []]])) + +(def: (lift on-pool) + (All [a] + (-> (State Pool a) + (Instruction a))) + (function (_ [pool tracker]) + (let [[pool' output] (state.run pool on-pool)] + [[pool' tracker] + [..partial-identity + output]]))) + +(def: max-u1 + (|> //unsigned.max-u1 //unsigned.nat //unsigned.u2)) + +(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] + ) + +(template [<name> <type> <constant> <ldc>] + [(def: #export (<name> value) + (-> <type> (Instruction Any)) + (do ..monad + [index (..lift (<constant> value))] + (..nullary (<ldc> index))))] + + [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>] + [(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] + ) + +(exception: #export (unknown-label {label Label}) + (exception.report + ["Label" (%.nat label)])) + +(exception: #export (cannot-do-a-big-jump {label Label} + {@from Address} + {jump Big-Jump}) + (exception.report + ["Label" (%.nat label)] + ["Start" (%.nat @from)] + ["Target" (|> jump //signed.int %.int)])) + +(def: (jump @from @to) + (-> Address Address (Either Jump Big-Jump)) + (let [jump (.int (n/- @to @from)) + big? (n/> (//unsigned.nat //unsigned.max-u2) + (.nat (i/* (if (i/>= +0 jump) + +1 + -1) + jump)))] + (if big? + (#.Right (//signed.s4 jump)) + (#.Left (//signed.s2 jump))))) + +(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] + + [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-acmpeq /bytecode.if-acmpeq] + [if-acmpne /bytecode.if-acmpne] + + [ifnull /bytecode.ifnull] + [ifnonnull /bytecode.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] + ) + +(template [<name> <bytecode>] + [(def: #export (<name> class) + (-> External (Instruction Any)) + (do ..monad + ## TODO: Make sure it"s impossible to have indexes greater than U2. + [index (..lift (//constant/pool.class (//name.internal class)))] + (..nullary (<bytecode> index))))] + + [new /bytecode.new] + [anewarray /bytecode.anewarray] + [checkcast /bytecode.checkcast] + [instanceof /bytecode.instanceof] + ) + +(def: #export (iinc register increase) + (-> Local U1 (Instruction Any)) + (..nullary (/bytecode.iinc register increase))) + +(def: #export (multianewarray class count) + (-> External U1 (Instruction Any)) + (do ..monad + [index (..lift (//constant/pool.class (//name.internal class)))] + (..nullary (/bytecode.multianewarray index count)))) + +(def: (descriptor-size descriptor) + (-> (Descriptor (Return Any)) U1) + (//unsigned.u1 + (cond (is? //descriptor.void descriptor) + 0 + + (is? //descriptor.long descriptor) + 2 + + (is? //descriptor.double descriptor) + 2 + + ## else + 1))) + +(template [<static?> <name> <bytecode>] + [(def: #export (<name> class method inputs output) + (-> External Text (List (Descriptor (Value Any))) (Descriptor (Return Any)) (Instruction Any)) + (do ..monad + [index (<| ..lift + (//constant/pool.method class) + {#//constant/pool.name method + #//constant/pool.descriptor (//descriptor.method inputs output)})] + (..nullary (<bytecode> + index + (|> inputs + (list@map descriptor-size) + (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1)))) + (descriptor-size output)))))] + + [#1 invokestatic /bytecode.invokestatic] + [#0 invokevirtual /bytecode.invokevirtual] + [#0 invokespecial /bytecode.invokespecial] + [#0 invokeinterface /bytecode.invokeinterface] + ) + +(template [<name> <1> <2>] + [(def: #export (<name> class field type) + (-> External Text (Descriptor Field) (Instruction Any)) + (do ..monad + [index (<| ..lift + (//constant/pool.field class) + {#//constant/pool.name field + #//constant/pool.descriptor type})] + (..nullary (cond (is? //descriptor.long type) + (<2> index) + + (is? //descriptor.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] + ) diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/instruction/bytecode.lux index 4f9c43f56..bef2628f6 100644 --- a/stdlib/source/lux/target/jvm/program/instruction.lux +++ b/stdlib/source/lux/target/jvm/instruction/bytecode.lux @@ -31,16 +31,16 @@ (type: #export Size Nat) -(type: #export Instruction +(type: #export Bytecode [Size (-> [Environment Specification] (Try [Environment Specification]))]) -(def: #export (run instruction) - (-> Instruction (Try [Environment Specification])) - (let [[_ instruction'] instruction] - (instruction' [/.start binaryF.no-op]))) +(def: #export (run bytecode) + (-> Bytecode (Try [Environment Specification])) + (let [[_ bytecode'] bytecode] + (bytecode' [/.start binaryF.no-op]))) -(def: (instruction size condition transform) - (-> Size Condition (-> Specification Specification) Instruction) +(def: (bytecode size condition transform) + (-> Size Condition (-> Specification Specification) Bytecode) [size (function (_ [environment specification]) (do try.monad @@ -381,8 +381,8 @@ ["B5" putfield/1 2 1] ["B5" putfield/2 2 2])] (template [<arity> <size> <definitions>] [(with-expansions [<definitions>' (template.splice <definitions>)] - (template [<code> <name> <instruction-inputs> <arity-inputs> <consumes> <produces> <locals>] - [(with-expansions [<inputs>' (template.splice <instruction-inputs>) + (template [<code> <name> <bytecode-inputs> <arity-inputs> <consumes> <produces> <locals>] + [(with-expansions [<inputs>' (template.splice <bytecode-inputs>) <input-types> (template [<input-name> <input-type>] [<input-type>] @@ -393,8 +393,8 @@ <inputs>') <locals>' (template.splice <locals>)] (def: #export (<name> <input-names>) - (-> <input-types> Instruction) - (..instruction + (-> <input-types> Bytecode) + (..bytecode <size> (`` ($_ /@compose (/.consumes <consumes>) @@ -478,7 +478,7 @@ )) (structure: #export monoid - (Monoid Instruction) + (Monoid Bytecode) (def: identity ..nop) diff --git a/stdlib/source/lux/target/jvm/program/condition.lux b/stdlib/source/lux/target/jvm/instruction/condition.lux index 04bb8c60b..04bb8c60b 100644 --- a/stdlib/source/lux/target/jvm/program/condition.lux +++ b/stdlib/source/lux/target/jvm/instruction/condition.lux diff --git a/stdlib/source/lux/target/jvm/program/jump.lux b/stdlib/source/lux/target/jvm/instruction/jump.lux index 19f667cfe..19f667cfe 100644 --- a/stdlib/source/lux/target/jvm/program/jump.lux +++ b/stdlib/source/lux/target/jvm/instruction/jump.lux diff --git a/stdlib/source/lux/target/jvm/program/resources.lux b/stdlib/source/lux/target/jvm/instruction/resources.lux index fa83c4071..fa83c4071 100644 --- a/stdlib/source/lux/target/jvm/program/resources.lux +++ b/stdlib/source/lux/target/jvm/instruction/resources.lux diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux index 2b47be482..f3fcf3207 100644 --- a/stdlib/source/lux/target/jvm/method.lux +++ b/stdlib/source/lux/target/jvm/method.lux @@ -24,9 +24,9 @@ ["#/." code]] ["#." constant (#+ UTF8) ["#/." pool (#+ Pool)]] - ["#." program (#+ Program) + ["#." instruction (#+ Instruction) ["#/." condition] - ["#/." instruction]]]) + ["#/." bytecode]]]) (type: #export #rec Method {#modifier (Modifier Method) @@ -50,16 +50,16 @@ ) (def: #export (method modifier name descriptor attributes code) - (-> (Modifier Method) UTF8 (Descriptor //descriptor.Method) (List (State Pool Attribute)) (Program Any) + (-> (Modifier Method) UTF8 (Descriptor //descriptor.Method) (List (State Pool Attribute)) (Instruction Any) (State Pool Method)) (do state.monad [@name (//constant/pool.utf8 name) @descriptor (//constant/pool.descriptor descriptor) attributes (monad.seq @ attributes) - ?code (//program.resolve code) + ?code (//instruction.resolve code) [environment bytecode] (case (do try.monad - [[instruction output] ?code - [environment specification] (//program/instruction.run instruction)] + [[bytecode output] ?code + [environment specification] (//instruction/bytecode.run bytecode)] (wrap [environment (binaryF.instance specification)])) (#try.Success [environment bytecode]) (wrap [environment bytecode]) @@ -68,7 +68,7 @@ ## TODO: Allow error-management within ## the monad. (undefined)) - @code (//attribute.code {#//attribute/code.resources (get@ #//program/condition.resources environment) + @code (//attribute.code {#//attribute/code.resources (get@ #//instruction/condition.resources environment) #//attribute/code.code bytecode #//attribute/code.exception-table (row.row) #//attribute/code.attributes (row.row)})] diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux deleted file mode 100644 index 13cd8ae5b..000000000 --- a/stdlib/source/lux/target/jvm/program.lux +++ /dev/null @@ -1,523 +0,0 @@ -(.module: - [lux #* - [abstract - [monoid (#+ Monoid)] - [monad (#+ Monad do)]] - [control - ["." state (#+ State)] - ["." writer (#+ Writer)] - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - [number - ["." nat]] - [collection - ["." list ("#@." functor fold)] - ["." dictionary (#+ Dictionary)]]]] - ["." / #_ - ["#." condition (#+ Local)] - ["#." jump (#+ Jump Big-Jump)] - ["#." instruction (#+ Primitive-Array-Type Instruction) ("#@." monoid)] - ["/#" // #_ - ["#." index] - ["#." descriptor (#+ Descriptor Value Return Field)] - [encoding - ["#." name (#+ External)] - ["#." unsigned (#+ U1 U2)] - ["#." signed]] - ["#." constant (#+ UTF8) - ["#/."pool (#+ Pool)]]]]) - -(type: #export Label Nat) - -(type: #export Address Nat) - -(type: Resolver (Dictionary Label Address)) - -(type: Tracker - {#program-counter Address - #next-label Label - #known-labels Resolver}) - -(def: fresh - Tracker - {#program-counter 0 - #next-label 0 - #known-labels (dictionary.new nat.hash)}) - -(type: #export Partial - (-> Resolver (Try Instruction))) - -(def: partial-identity - Partial - (function.constant (#try.Success /instruction.nop))) - -(structure: partial-monoid - (Monoid Partial) - - (def: identity ..partial-identity) - - (def: (compose left right) - (cond (is? ..partial-identity left) - right - - (is? ..partial-identity right) - left - - ## else - (function (_ resolver) - (do try.monad - [left (left resolver) - right (right resolver)] - (wrap (/instruction@compose left right))))))) - -(type: #export (Program a) - (State [Pool Tracker] (Writer Partial a))) - -(def: #export new-label - (Program Label) - (function (_ [pool tracker]) - [[pool - (update@ #next-label inc tracker)] - [..partial-identity - (get@ #next-label tracker)]])) - -(def: #export (set-label label) - (-> Label (Program Any)) - (function (_ [pool tracker]) - [[pool - (update@ #known-labels - (dictionary.put label (get@ #program-counter tracker)) - tracker)] - [..partial-identity - []]])) - -(def: #export monad - ## TODO: Remove the coercion. It was added because the type-checker - ## seems to have a bug that is being triggered here. - (:coerce (Monad Program) - (writer.with ..partial-monoid - (: (Monad (State [Pool Tracker])) - state.monad)))) - -(def: #export (resolve program) - (All [a] (-> (Program a) (State Pool (Try [Instruction a])))) - (function (_ pool) - (let [[[pool tracker] [partial output]] (state.run [pool ..fresh] program)] - [pool (do try.monad - [instruction (partial (get@ #known-labels tracker))] - (wrap [instruction output]))]))) - -(def: (nullary instruction) - (-> Instruction (Program Any)) - (function (_ [pool tracker]) - [[pool tracker] - [(function.constant (#try.Success instruction)) - []]])) - -(template [<name> <instruction>] - [(def: #export <name> (nullary <instruction>))] - - [nop /instruction.nop] - [aconst-null /instruction.aconst-null] - - [iconst-m1 /instruction.iconst-m1] - [iconst-0 /instruction.iconst-0] - [iconst-1 /instruction.iconst-1] - [iconst-2 /instruction.iconst-2] - [iconst-3 /instruction.iconst-3] - [iconst-4 /instruction.iconst-4] - [iconst-5 /instruction.iconst-5] - - [lconst-0 /instruction.lconst-0] - [lconst-1 /instruction.lconst-1] - - [fconst-0 /instruction.fconst-0] - [fconst-1 /instruction.fconst-1] - [fconst-2 /instruction.fconst-2] - - [dconst-0 /instruction.dconst-0] - [dconst-1 /instruction.dconst-1] - - [pop /instruction.pop] - [pop2 /instruction.pop2] - - [dup /instruction.dup] - [dup-x1 /instruction.dup-x1] - [dup-x2 /instruction.dup-x2] - [dup2 /instruction.dup2] - [dup2-x1 /instruction.dup2-x1] - [dup2-x2 /instruction.dup2-x2] - - [swap /instruction.swap] - - [istore-0 /instruction.istore-0] - [istore-1 /instruction.istore-1] - [istore-2 /instruction.istore-2] - [istore-3 /instruction.istore-3] - - [lstore-0 /instruction.lstore-0] - [lstore-1 /instruction.lstore-1] - [lstore-2 /instruction.lstore-2] - [lstore-3 /instruction.lstore-3] - - [fstore-0 /instruction.fstore-0] - [fstore-1 /instruction.fstore-1] - [fstore-2 /instruction.fstore-2] - [fstore-3 /instruction.fstore-3] - - [dstore-0 /instruction.dstore-0] - [dstore-1 /instruction.dstore-1] - [dstore-2 /instruction.dstore-2] - [dstore-3 /instruction.dstore-3] - - [astore-0 /instruction.astore-0] - [astore-1 /instruction.astore-1] - [astore-2 /instruction.astore-2] - [astore-3 /instruction.astore-3] - - [iaload /instruction.iaload] - [laload /instruction.laload] - [faload /instruction.faload] - [daload /instruction.daload] - [aaload /instruction.aaload] - [baload /instruction.baload] - [caload /instruction.caload] - [saload /instruction.saload] - - [iastore /instruction.iastore] - [lastore /instruction.lastore] - [fastore /instruction.fastore] - [dastore /instruction.dastore] - [aastore /instruction.aastore] - [bastore /instruction.bastore] - [castore /instruction.castore] - [sastore /instruction.sastore] - - [iadd /instruction.iadd] - [isub /instruction.isub] - [imul /instruction.imul] - [idiv /instruction.idiv] - [irem /instruction.irem] - [ineg /instruction.ineg] - [ishl /instruction.ishl] - [ishr /instruction.ishr] - [iushr /instruction.iushr] - [iand /instruction.iand] - [ior /instruction.ior] - [ixor /instruction.ixor] - - [ladd /instruction.ladd] - [lsub /instruction.lsub] - [lmul /instruction.lmul] - [ldiv /instruction.ldiv] - [lrem /instruction.lrem] - [lneg /instruction.lneg] - [land /instruction.land] - [lor /instruction.lor] - [lxor /instruction.lxor] - - [fadd /instruction.fadd] - [fsub /instruction.fsub] - [fmul /instruction.fmul] - [fdiv /instruction.fdiv] - [frem /instruction.frem] - [fneg /instruction.fneg] - - [dadd /instruction.dadd] - [dsub /instruction.dsub] - [dmul /instruction.dmul] - [ddiv /instruction.ddiv] - [drem /instruction.drem] - [dneg /instruction.dneg] - - [lshl /instruction.lshl] - [lshr /instruction.lshr] - [lushr /instruction.lushr] - - [l2i /instruction.l2i] - [l2f /instruction.l2f] - [l2d /instruction.l2d] - - [f2i /instruction.f2i] - [f2l /instruction.f2l] - [f2d /instruction.f2d] - - [d2i /instruction.d2i] - [d2l /instruction.d2l] - [d2f /instruction.d2f] - - [i2l /instruction.i2l] - [i2f /instruction.i2f] - [i2d /instruction.i2d] - [i2b /instruction.i2b] - [i2c /instruction.i2c] - [i2s /instruction.i2s] - - [lcmp /instruction.lcmp] - - [fcmpl /instruction.fcmpl] - [fcmpg /instruction.fcmpg] - - [dcmpl /instruction.dcmpl] - [dcmpg /instruction.dcmpg] - - [ireturn /instruction.ireturn] - [lreturn /instruction.lreturn] - [freturn /instruction.freturn] - [dreturn /instruction.dreturn] - [areturn /instruction.areturn] - [return /instruction.return] - - [arraylength /instruction.arraylength] - - [athrow /instruction.athrow] - - [monitorenter /instruction.monitorenter] - [monitorexit /instruction.monitorexit] - ) - -(def: #export (bipush byte) - (-> U1 (Program Any)) - (function (_ [pool tracker]) - [[pool tracker] - [(function.constant (#try.Success (/instruction.bipush byte))) - []]])) - -(def: (lift on-pool) - (All [a] - (-> (State Pool a) - (Program a))) - (function (_ [pool tracker]) - (let [[pool' output] (state.run pool on-pool)] - [[pool' tracker] - [..partial-identity - output]]))) - -(def: max-u1 - (|> //unsigned.max-u1 //unsigned.nat //unsigned.u2)) - -(template [<name> <type> <constant> <ldc>] - [(def: #export (<name> value) - (-> <type> (Program Any)) - (do ..monad - [index (..lift (<constant> value)) - #let [index' (//index.number index)]] - (..nullary (if (:: //unsigned.order < ..max-u1 index') - (/instruction.ldc (|> index' //unsigned.nat //unsigned.u1)) - (<ldc> index)))))] - - [ldc/string //constant.UTF8 //constant/pool.string /instruction.ldc-w/string] - ) - -(template [<name> <type> <constant> <ldc>] - [(def: #export (<name> value) - (-> <type> (Program Any)) - (do ..monad - [index (..lift (<constant> value))] - (..nullary (<ldc> index))))] - - [ldc/integer //constant.Integer //constant/pool.integer /instruction.ldc-w/integer] - [ldc/long //constant.Long //constant/pool.long /instruction.ldc2-w/long] - [ldc/float //constant.Float //constant/pool.float /instruction.ldc-w/float] - [ldc/double //constant.Double //constant/pool.double /instruction.ldc2-w/double] - ) - -(template [<name> <instruction> <input>] - [(def: #export <name> - (-> <input> (Program Any)) - (|>> <instruction> nullary))] - - [iload /instruction.iload Local] - [lload /instruction.lload Local] - [fload /instruction.fload Local] - [dload /instruction.dload Local] - [aload /instruction.aload Local] - - [istore /instruction.istore Local] - [lstore /instruction.lstore Local] - [fstore /instruction.fstore Local] - [dstore /instruction.dstore Local] - [astore /instruction.astore Local] - - [ret /instruction.ret Local] - - [newarray /instruction.newarray Primitive-Array-Type] - - [sipush /instruction.sipush U2] - ) - -(exception: #export (unknown-label {label Label}) - (exception.report - ["Label" (%.nat label)])) - -(exception: #export (cannot-do-a-big-jump {label Label} - {@from Address} - {jump Big-Jump}) - (exception.report - ["Label" (%.nat label)] - ["Start" (%.nat @from)] - ["Target" (|> jump //signed.int %.int)])) - -(def: (jump @from @to) - (-> Address Address (Either Jump Big-Jump)) - (let [jump (.int (n/- @to @from)) - big? (n/> (//unsigned.nat //unsigned.max-u2) - (.nat (i/* (if (i/>= +0 jump) - +1 - -1) - jump)))] - (if big? - (#.Right (//signed.s4 jump)) - (#.Left (//signed.s2 jump))))) - -(template [<name> <instruction>] - [(def: #export (<name> label) - (-> Label (Program 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 (<instruction> jump)) - - (#.Right jump) - (exception.throw ..cannot-do-a-big-jump [label @from jump])) - - #.None - (exception.throw ..unknown-label [label]))) - []]])))] - - [ifeq /instruction.ifeq] - [ifne /instruction.ifne] - [iflt /instruction.iflt] - [ifge /instruction.ifge] - [ifgt /instruction.ifgt] - [ifle /instruction.ifle] - - [if-icmpeq /instruction.if-icmpeq] - [if-icmpne /instruction.if-icmpne] - [if-icmplt /instruction.if-icmplt] - [if-icmpge /instruction.if-icmpge] - [if-icmpgt /instruction.if-icmpgt] - [if-icmple /instruction.if-icmple] - - [if-acmpeq /instruction.if-acmpeq] - [if-acmpne /instruction.if-acmpne] - - [ifnull /instruction.ifnull] - [ifnonnull /instruction.ifnonnull] - ) - -(template [<name> <normal-instruction> <wide-instruction>] - [(def: #export (<name> label) - (-> Label (Program 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-instruction> jump)) - - (#.Right jump) - (#try.Success (<wide-instruction> jump))) - - #.None - (exception.throw ..unknown-label [label]))) - []]])))] - - [goto /instruction.goto /instruction.goto-w] - [jsr /instruction.jsr /instruction.jsr-w] - ) - -(template [<name> <instruction>] - [(def: #export (<name> class) - (-> External (Program Any)) - (do ..monad - ## TODO: Make sure it"s impossible to have indexes greater than U2. - [index (..lift (//constant/pool.class (//name.internal class)))] - (..nullary (<instruction> index))))] - - [new /instruction.new] - [anewarray /instruction.anewarray] - [checkcast /instruction.checkcast] - [instanceof /instruction.instanceof] - ) - -(def: #export (iinc register increase) - (-> Local U1 (Program Any)) - (..nullary (/instruction.iinc register increase))) - -(def: #export (multianewarray class count) - (-> External U1 (Program Any)) - (do ..monad - [index (..lift (//constant/pool.class (//name.internal class)))] - (..nullary (/instruction.multianewarray index count)))) - -(def: (descriptor-size descriptor) - (-> (Descriptor (Return Any)) U1) - (//unsigned.u1 - (cond (is? //descriptor.void descriptor) - 0 - - (is? //descriptor.long descriptor) - 2 - - (is? //descriptor.double descriptor) - 2 - - ## else - 1))) - -(template [<static?> <name> <instruction>] - [(def: #export (<name> class method inputs output) - (-> External Text (List (Descriptor (Value Any))) (Descriptor (Return Any)) (Program Any)) - (do ..monad - [index (<| ..lift - (//constant/pool.method class) - {#//constant/pool.name method - #//constant/pool.descriptor (//descriptor.method inputs output)})] - (..nullary (<instruction> - index - (|> inputs - (list@map descriptor-size) - (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1)))) - (descriptor-size output)))))] - - [#1 invokestatic /instruction.invokestatic] - [#0 invokevirtual /instruction.invokevirtual] - [#0 invokespecial /instruction.invokespecial] - [#0 invokeinterface /instruction.invokeinterface] - ) - -(template [<name> <1> <2>] - [(def: #export (<name> class field type) - (-> External Text (Descriptor Field) (Program Any)) - (do ..monad - [index (<| ..lift - (//constant/pool.field class) - {#//constant/pool.name field - #//constant/pool.descriptor type})] - (..nullary (cond (is? //descriptor.long type) - (<2> index) - - (is? //descriptor.double type) - (<2> index) - - ## else - (<1> index)))))] - - [getstatic /instruction.getstatic/1 /instruction.getstatic/2] - [putstatic /instruction.putstatic/1 /instruction.putstatic/2] - [getfield /instruction.getfield/1 /instruction.getfield/2] - [putfield /instruction.putfield/1 /instruction.putfield/2] - ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux index d0d819925..2807487ae 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux @@ -6,21 +6,21 @@ [jvm ["|" descriptor] ["." constant] - ["_" program (#+ Program)]]] + ["_" instruction (#+ Instruction)]]] [macro ["." template]]] ["." // #_ ["#." runtime]]) (def: #export (bit value) - (-> Bit (Program Any)) + (-> Bit (Instruction Any)) (_.getstatic "java.lang.Boolean" (if value "TRUE" "FALSE") (|.object "java.lang.Boolean"))) (template [<name> <inputT> <ldc> <class> <inputD>] [(def: #export (<name> value) - (-> <inputT> (Program Any)) + (-> <inputT> (Instruction Any)) (do _.monad [_ (`` (|> value (~~ (template.splice <ldc>))))] (_.invokestatic <class> "valueOf" 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 f43fc907a..b45965dc5 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -4,7 +4,7 @@ [binary (#+ Binary)]] [target [jvm - ["_" program (#+ Label Program)]]]] + ["_" instruction (#+ Label Instruction)]]]] ["." /// [/// [reference (#+ Register)]]] @@ -18,7 +18,7 @@ (template [<name> <base>] [(type: #export <name> - (<base> Anchor (Program Any) Definition))] + (<base> Anchor (Instruction Any) Definition))] [Operation ///.Operation] [Phase ///.Phase] @@ -27,6 +27,6 @@ ) (type: #export (Generator i) - (-> Phase i (Operation (Program Any)))) + (-> Phase i (Operation (Instruction Any)))) (def: #export class "LuxRuntime") diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux index beeeea2c7..1282ac245 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux @@ -11,7 +11,7 @@ [jvm ["|" descriptor] ["_." constant] - ["_" program (#+ Program)]]]] + ["_" instruction (#+ Instruction)]]]] ["." // #_ ["#." runtime (#+ Operation Phase Generator)] ["#." primitive] @@ -20,7 +20,7 @@ [analysis (#+ Variant Tuple)] ["#." synthesis (#+ Synthesis)]]]]) -(def: unitG (Program Any) (//primitive.text /////synthesis.unit)) +(def: unitG (Instruction Any) (//primitive.text /////synthesis.unit)) (template: (!integer <value>) (|> <value> .i64 i32.i32 _constant.integer)) @@ -52,7 +52,7 @@ (monad.seq @ membersI)))))) (def: (flagG right?) - (-> Bit (Program Any)) + (-> Bit (Instruction Any)) (if right? ..unitG _.aconst-null)) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 8f97645b4..def28b2a0 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -39,9 +39,8 @@ ["#/." pool]] [encoding ["#." name]] - ["#." program - ["#/." condition (#+ Environment)] - ["#/." instruction]]]}) + ["#." instruction + ["#/." condition (#+ Environment)]]]}) ## (def: (write-class! name bytecode) ## (-> Text Binary (IO Text)) @@ -132,12 +131,12 @@ method-name (/descriptor.method inputsJT outputJT) (list) - (do /program.monad - [_ (/program.ldc/long (/constant.long expected)) - _ (/program.invokestatic "java.lang.Long" "valueOf" - (list /descriptor.long) - (/descriptor.object "java.lang.Long"))] - /program.areturn))) + (do /instruction.monad + [_ (/instruction.ldc/long (/constant.long expected)) + _ (/instruction.invokestatic "java.lang.Long" "valueOf" + (list /descriptor.long) + (/descriptor.object "java.lang.Long"))] + /instruction.areturn))) (row.row)) (binaryF.run /class.writer)) loader (/loader.memory (/loader.new-library []))] |