aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux26
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux43
-rw-r--r--stdlib/source/lux/target/jvm/encoding/unsigned.lux10
-rw-r--r--stdlib/source/lux/target/jvm/program.lux384
-rw-r--r--stdlib/source/lux/target/jvm/program/instruction.lux8
-rw-r--r--stdlib/source/lux/target/jvm/program/jump.lux (renamed from stdlib/source/lux/target/jvm/program/label.lux)4
6 files changed, 421 insertions, 54 deletions
diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
index 9c4c1ed38..19de9c789 100644
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
@@ -13,22 +13,22 @@
[constant (#+ Class)]
["#." index (#+ Index)]
[program
- ["#." label (#+ Label)]]
+ ["#." jump (#+ Jump)]]
[encoding
["#." unsigned (#+ U2)]]]])
(type: #export Exception
- {#start-pc Label
- #end-pc Label
- #handler-pc Label
+ {#start-pc Jump
+ #end-pc Jump
+ #handler-pc Jump
#catch-type (Index Class)})
(def: #export equivalence
(Equivalence Exception)
($_ equivalence.product
- ////label.equivalence
- ////label.equivalence
- ////label.equivalence
+ ////jump.equivalence
+ ////jump.equivalence
+ ////jump.equivalence
////index.equivalence
))
@@ -49,17 +49,17 @@
(def: #export parser
(Parser Exception)
($_ <>.and
- ////label.parser
- ////label.parser
- ////label.parser
+ ////jump.parser
+ ////jump.parser
+ ////jump.parser
////index.parser
))
(def: #export writer
(Writer Exception)
($_ binaryF.and
- ////label.writer
- ////label.writer
- ////label.writer
+ ////jump.writer
+ ////jump.writer
+ ////jump.writer
////index.writer
))
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
index 149a893bb..c9e136380 100644
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ b/stdlib/source/lux/target/jvm/constant/pool.lux
@@ -10,7 +10,10 @@
["<2>" binary (#+ Parser)]]]
[data
["." error (#+ Error)]
- ["." text ("#;." equivalence)
+ [number
+ ["." int]
+ ["." frac]]
+ ["." text
["%" format]]
[format
[".F" binary (#+ Writer)]]
@@ -18,8 +21,10 @@
["." list ("#;." fold)]
["." row (#+ Row)]]]
[type
- abstract]]
- ["." // (#+ UTF8 Class Constant) ("#;." class-equivalence)
+ abstract]
+ [macro
+ ["." template]]]
+ ["." // (#+ UTF8 Class Long Double Constant)
[//
[encoding
["." unsigned]]
@@ -43,7 +48,7 @@
(#.Some entry)
(case entry
(<tag> reference)
- (if (<=> reference <value>)
+ (if (:: <=> = reference <value>)
[pool
<index>]
<try-again>)
@@ -99,7 +104,7 @@
(#.Some entry)
(case entry
(<tag> actual)
- (if (<=> actual <expected>)
+ (if (:: <=> = actual <expected>)
[pool
(#error.Success <index>)]
<try-again>)
@@ -120,21 +125,27 @@
(type: (Finder of)
(-> of (State Pool (Error (Index of)))))
-(def: #export (utf8 value)
- (Adder UTF8)
- (!add #//.UTF8 text;= value))
+(template [<name> <type> <tag> <equivalence> <format>]
+ [(def: #export (<name> value)
+ (Adder <type>)
+ (!add <tag> <equivalence> value))
-(def: #export (fetch-utf8 index)
- (Fetcher UTF8)
- (!fetch #//.UTF8 index))
+ (`` (def: #export ((~~ (template.identifier ["fetch-" <name>])) index)
+ (Fetcher <type>)
+ (!fetch <tag> index)))
-(def: #export (find-utf8 reference)
- (Finder UTF8)
- (!find #//.UTF8 text;= %.text reference))
+ (`` (def: #export ((~~ (template.identifier ["find-" <name>])) reference)
+ (Finder <type>)
+ (!find <tag> <equivalence> <format> reference)))]
+
+ [long Long #//.Long (//.value-equivalence int.equivalence) (|>> //.value %.int)]
+ [double Double #//.Double (//.value-equivalence frac.equivalence) (|>> //.value %.frac)]
+ [utf8 UTF8 #//.UTF8 text.equivalence %.text]
+ )
(def: (class' value)
(Adder Class)
- (!add #//.Class //;= value))
+ (!add #//.Class //.class-equivalence value))
(def: #export (class name)
(-> UTF8 (State Pool (Index Class)))
@@ -147,7 +158,7 @@
(-> (Descriptor kind)
(State Pool (Index (Descriptor kind)))))
(let [value (descriptor.descriptor value)]
- (!add #//.UTF8 text;= value)))
+ (!add #//.UTF8 text.equivalence value)))
(def: #export parser
(Parser Pool)
diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
index 86495f38e..892d2f86d 100644
--- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux
+++ b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
@@ -1,7 +1,8 @@
(.module:
[lux (#- nat)
[abstract
- [equivalence (#+ Equivalence)]]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
[control
["<>" parser ("#@." functor)
["<2>" binary (#+ Parser)]]]
@@ -28,6 +29,13 @@
(def: (= reference sample)
(n/= (:representation reference) (:representation sample))))
+ (structure: #export order
+ (All [brand] (Order (Unsigned brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: (< reference sample)
+ (n/< (:representation reference) (:representation sample))))
+
(template [<bytes> <name> <size> <constructor> <max> <+>]
[(with-expansions [<raw> (template.identifier [<name> "'"])]
(abstract: #export <raw> {} Any)
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
index 9d5dbe06c..673743c73 100644
--- a/stdlib/source/lux/target/jvm/program.lux
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -6,23 +6,29 @@
[control
["." state (#+ State)]
["." writer (#+ Writer)]
- ["." function]]
+ ["." function]
+ ["." exception (#+ exception:)]]
[data
["." error (#+ Error)]
+ [text
+ ["%" format]]
[number
["." nat]]
[collection
["." dictionary (#+ Dictionary)]]]]
["." / #_
- ["#." instruction (#+ Instruction) ("#@." monoid)]
- [//
+ ["#." condition (#+ Local)]
+ ["#." jump (#+ Jump Big-Jump)]
+ ["#." instruction (#+ Primitive-Array-Type Instruction) ("#@." monoid)]
+ ["/#" // #_
+ ["#." index]
[encoding
- [unsigned (#+ U2)]]]])
+ ["#." unsigned (#+ U1 U2)]]
+ ["#." constant (#+ UTF8)
+ ["#/."pool (#+ Pool)]]]])
(type: #export Label Nat)
-(type: #export Jump U2)
-
(type: #export Address Nat)
(type: Resolver (Dictionary Label Address))
@@ -65,21 +71,23 @@
(wrap (/instruction@compose left right)))))))
(type: #export (Program a)
- (State Tracker (Writer Partial a)))
+ (State [Pool Tracker] (Writer Partial a)))
(def: #export new-label
(Program Label)
- (function (_ tracker)
- [(update@ #next-label inc tracker)
+ (function (_ [pool tracker])
+ [[pool
+ (update@ #next-label inc tracker)]
[..partial-identity
(get@ #next-label tracker)]]))
(def: #export (set-label label)
(-> Label (Program Any))
- (function (_ tracker)
- [(update@ #known-labels
- (dictionary.put label (get@ #program-counter tracker))
- tracker)
+ (function (_ [pool tracker])
+ [[pool
+ (update@ #known-labels
+ (dictionary.put label (get@ #program-counter tracker))
+ tracker)]
[..partial-identity
[]]]))
@@ -88,12 +96,352 @@
## seems to have a bug that is being triggered here.
(:coerce (Monad Program)
(writer.with ..partial-monoid
- (: (Monad (State Tracker))
+ (: (Monad (State [Pool Tracker]))
state.monad))))
-(def: #export (resolve program)
- (All [a] (-> (Program a) (Error [Instruction a])))
- (let [[tracker [partial output]] (state.run ..fresh program)]
+(def: #export (resolve pool program)
+ (All [a] (-> Pool (Program a) (Error [Pool Instruction a])))
+ (let [[[pool tracker] [partial output]] (state.run [pool ..fresh] program)]
(do error.monad
[instruction (partial (get@ #known-labels tracker))]
- (wrap [instruction output]))))
+ (wrap [pool instruction output]))))
+
+(def: (nullary instruction)
+ (-> Instruction (Program Any))
+ (function (_ [pool tracker])
+ [[pool tracker]
+ [(function.constant (#error.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 (#error.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/long //constant.Long //constant/pool.long /instruction.ldc2-w/long]
+ [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 //unsigned.nat .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 (//unsigned.u4 (.nat jump)))
+ (#.Left (//unsigned.u2 (.nat 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)
+ (#error.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)
+ (#error.Success (<normal-instruction> jump))
+
+ (#.Right jump)
+ (#error.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)
+ (-> UTF8 (Program Any))
+ (do ..monad
+ ## TODO: Make sure it"s impossible to have indexes greater than U2.
+ [index (..lift (//constant/pool.class 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)
+ (-> UTF8 U1 (Program Any))
+ (do ..monad
+ [index (..lift (//constant/pool.class class))]
+ (..nullary (/instruction.multianewarray index count))))
diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index fcb2c1be7..373801405 100644
--- a/stdlib/source/lux/target/jvm/program/instruction.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -20,7 +20,7 @@
["." // #_
["#." resources (#+ Resources)]
["/" condition (#+ Environment Condition Local) ("#@." monoid)]
- ["#." label (#+ Label Wide-Label)]
+ ["#." jump (#+ Jump Big-Jump)]
["/#" // #_
["#." index (#+ Index)]
["#." descriptor (#+ Field Method)]
@@ -362,7 +362,7 @@
["B1" return 0]
)
<jumps> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [[label Label]] [label] <input-size> <output-size> []]]
+ [[<code> <name> [[jump Jump]] [jump] <input-size> <output-size> []]]
["99" ifeq 2 0]
["9A" ifne 2 0]
@@ -475,8 +475,8 @@
["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
[..unary/4 5
- [["C8" goto-w [[label Wide-Label]] [label] 0 0 []]
- ["C9" jsr-w [[label Wide-Label]] [label] 0 1 []]]]
+ [["C8" goto-w [[jump Big-Jump]] [jump] 0 0 []]
+ ["C9" jsr-w [[jump Big-Jump]] [jump] 0 1 []]]]
[..binary/11 3
[["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]]
diff --git a/stdlib/source/lux/target/jvm/program/label.lux b/stdlib/source/lux/target/jvm/program/jump.lux
index 7aaff5739..49a4e42ea 100644
--- a/stdlib/source/lux/target/jvm/program/label.lux
+++ b/stdlib/source/lux/target/jvm/program/jump.lux
@@ -6,7 +6,7 @@
[encoding
["#." unsigned (#+ U2 U4)]]])
-(type: #export Label U2)
+(type: #export Jump U2)
(def: #export equivalence
///unsigned.equivalence)
@@ -17,4 +17,4 @@
(def: #export writer
///unsigned.u2-writer)
-(type: #export Wide-Label U4)
+(type: #export Big-Jump U4)