aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code.lux2
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux2
-rw-r--r--stdlib/source/lux/target/jvm/attribute/constant.lux4
-rw-r--r--stdlib/source/lux/target/jvm/instruction.lux523
-rw-r--r--stdlib/source/lux/target/jvm/instruction/bytecode.lux (renamed from stdlib/source/lux/target/jvm/program/instruction.lux)24
-rw-r--r--stdlib/source/lux/target/jvm/instruction/condition.lux (renamed from stdlib/source/lux/target/jvm/program/condition.lux)0
-rw-r--r--stdlib/source/lux/target/jvm/instruction/jump.lux (renamed from stdlib/source/lux/target/jvm/program/jump.lux)0
-rw-r--r--stdlib/source/lux/target/jvm/instruction/resources.lux (renamed from stdlib/source/lux/target/jvm/program/resources.lux)0
-rw-r--r--stdlib/source/lux/target/jvm/method.lux14
-rw-r--r--stdlib/source/lux/target/jvm/program.lux523
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux6
-rw-r--r--stdlib/source/test/lux/target/jvm.lux17
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 []))]