diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/target/jvm/attribute/code/exception.lux | 26 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/constant/pool.lux | 43 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/encoding/unsigned.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/program.lux | 384 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/program/instruction.lux | 8 | ||||
| -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) |