From 8a65c2faa8b0f038e93536af27940c359eb1d3fd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 25 Jun 2019 22:14:07 -0400 Subject: WIP: Label resolution support for JVM instructions. --- stdlib/source/lux/target/jvm/attribute/code.lux | 2 +- .../lux/target/jvm/attribute/code/exception.lux | 2 +- stdlib/source/lux/target/jvm/code.lux | 494 -------------------- stdlib/source/lux/target/jvm/code/condition.lux | 75 --- stdlib/source/lux/target/jvm/code/label.lux | 20 - stdlib/source/lux/target/jvm/code/resources.lux | 51 --- stdlib/source/lux/target/jvm/program.lux | 99 ++++ stdlib/source/lux/target/jvm/program/condition.lux | 75 +++ .../source/lux/target/jvm/program/instruction.lux | 501 +++++++++++++++++++++ stdlib/source/lux/target/jvm/program/label.lux | 20 + stdlib/source/lux/target/jvm/program/resources.lux | 51 +++ 11 files changed, 748 insertions(+), 642 deletions(-) delete mode 100644 stdlib/source/lux/target/jvm/code.lux delete mode 100644 stdlib/source/lux/target/jvm/code/condition.lux delete mode 100644 stdlib/source/lux/target/jvm/code/label.lux delete mode 100644 stdlib/source/lux/target/jvm/code/resources.lux create mode 100644 stdlib/source/lux/target/jvm/program.lux create mode 100644 stdlib/source/lux/target/jvm/program/condition.lux create mode 100644 stdlib/source/lux/target/jvm/program/instruction.lux create mode 100644 stdlib/source/lux/target/jvm/program/label.lux create mode 100644 stdlib/source/lux/target/jvm/program/resources.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux index 68c651ba5..dff626c5c 100644 --- a/stdlib/source/lux/target/jvm/attribute/code.lux +++ b/stdlib/source/lux/target/jvm/attribute/code.lux @@ -13,7 +13,7 @@ [collection ["." row (#+ Row) ("#@." functor fold)]]]] ["." /// #_ - [code + [program ["#." 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 14dd13d6e..9c4c1ed38 100644 --- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux +++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux @@ -12,7 +12,7 @@ ["//#" /// #_ [constant (#+ Class)] ["#." index (#+ Index)] - [code + [program ["#." label (#+ Label)]] [encoding ["#." unsigned (#+ U2)]]]]) diff --git a/stdlib/source/lux/target/jvm/code.lux b/stdlib/source/lux/target/jvm/code.lux deleted file mode 100644 index 480999e93..000000000 --- a/stdlib/source/lux/target/jvm/code.lux +++ /dev/null @@ -1,494 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." exception (#+ exception:)]] - [data - [number (#+ hex)] - ["." error (#+ Error)] - ["." binary] - [text - ["%" format (#+ format)]] - [format - [".F" binary (#+ Mutation Specification)]]] - [macro - ["." template]] - [type - abstract]] - ["." // #_ - ["#." index (#+ Index)] - ["#." descriptor (#+ Field Method)] - ["#." constant (#+ Class Reference)] - [encoding - ["#." unsigned (#+ U1 U2 U4)]]] - ["." / #_ - ["#." resources (#+ Resources)] - ["#" condition (#+ Environment Condition Local) ("#@." monoid)] - ["#." label (#+ Label Wide-Label)]]) - -(type: #export Instruction - (-> [Environment Specification] (Error [Environment Specification]))) - -(def: (instruction condition transform) - (-> Condition (-> Specification Specification) Instruction) - (function (_ [environment specification]) - (do error.monad - [environment' (condition environment)] - (wrap [environment' - (transform specification)])))) - -(def: (nullary' code) - (-> Nat Mutation) - (function (_ [offset binary]) - [(n/+ 1 offset) - (error.assume - (binary.write/8 offset code binary))])) - -(def: (nullary code [size mutation]) - (-> Nat (-> Specification Specification)) - [(n/+ 1 size) - (|>> mutation ((nullary' code)))]) - -(def: (unary/1' code input0) - (-> Nat U1 Mutation) - (function (_ [offset binary]) - [(n/+ 2 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary)] - (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)))])) - -(def: (unary/1 code input0 [size mutation]) - (-> Nat U1 (-> Specification Specification)) - [(n/+ 2 size) - (|>> mutation ((unary/1' code input0)))]) - -(def: (unary/2' code input0) - (-> Nat U2 Mutation) - (function (_ [offset binary]) - [(n/+ 3 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary)] - (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))])) - -(def: (unary/2 code input0 [size mutation]) - (-> Nat U2 (-> Specification Specification)) - [(n/+ 3 size) - (|>> mutation ((unary/2' code input0)))]) - -(def: (unary/4' code input0) - (-> Nat U4 Mutation) - (function (_ [offset binary]) - [(n/+ 5 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary)] - (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))])) - -(def: (unary/4 code input0 [size mutation]) - (-> Nat U4 (-> Specification Specification)) - [(n/+ 5 size) - (|>> mutation ((unary/4' code input0)))]) - -(def: (binary/11' code input0 input1) - (-> Nat U1 U1 Mutation) - (function (_ [offset binary]) - [(n/+ 3 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)] - (binary.write/8 (n/+ 2 offset) (//unsigned.nat input1) binary)))])) - -(def: (binary/11 code input0 input1 [size mutation]) - (-> Nat U1 U1 (-> Specification Specification)) - [(n/+ 3 size) - (|>> mutation ((binary/11' code input0 input1)))]) - -(def: (binary/21' code input0 input1) - (-> Nat U2 U1 Mutation) - (function (_ [offset binary]) - [(n/+ 4 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)] - (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)))])) - -(def: (binary/21 code input0 input1 [size mutation]) - (-> Nat U2 U1 (-> Specification Specification)) - [(n/+ 4 size) - (|>> mutation ((binary/21' code input0 input1)))]) - -(def: (trinary/211' code input0 input1 input2) - (-> Nat U2 U1 U1 Mutation) - (function (_ [offset binary]) - [(n/+ 5 offset) - (error.assume - (do error.monad - [_ (binary.write/8 offset code binary) - _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary) - _ (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)] - (binary.write/8 (n/+ 4 offset) (//unsigned.nat input2) binary)))])) - -(def: (trinary/211 code input0 input1 input2 [size mutation]) - (-> Nat U2 U1 U1 (-> Specification Specification)) - [(n/+ 5 size) - (|>> mutation ((trinary/211' code input0 input1 input2)))]) - -(abstract: #export Primitive-Array-Type - {} - - U1 - - (def: code - (-> Primitive-Array-Type U1) - (|>> :representation)) - - (template [ ] - [(def: #export (|> //unsigned.u1 :abstraction))] - - [04 t-boolean] - [05 t-char] - [06 t-float] - [07 t-double] - [08 t-byte] - [09 t-short] - [10 t-int] - [11 t-long] - )) - -## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 -(with-expansions [ (template [ ] - [[ [] [] 0 []]] - - ["01" aconst-null 1] - - ["02" iconst-m1 1] - ["03" iconst-0 1] - ["04" iconst-1 1] - ["05" iconst-2 1] - ["06" iconst-3 1] - ["07" iconst-4 1] - ["08" iconst-5 1] - - ["09" lconst-0 2] - ["0A" lconst-1 2] - - ["0B" fconst-0 1] - ["0C" fconst-1 1] - ["0D" fconst-2 1] - - ["0E" dconst-0 2] - ["0F" dconst-1 2]) - (template [ ] - [[ [[local Local]] [local] 0 [[local]]]] - - ["15" iload 1] - ["16" lload 2] - ["17" fload 1] - ["18" dload 2] - ["19" aload 1]) - (template [ ] - [[ [] [] 0 [[(//unsigned.u1 )]]]] - - ["1A" iload-0 1 0] - ["1B" iload-1 1 1] - ["1C" iload-2 1 2] - ["1D" iload-3 1 3] - - ["1E" lload-0 2 1] - ["1F" lload-1 2 2] - ["20" lload-2 2 3] - ["21" lload-3 2 4] - - ["22" fload-0 1 0] - ["23" fload-1 1 1] - ["24" fload-2 1 2] - ["25" fload-3 1 3] - - ["26" dload-0 2 1] - ["27" dload-1 2 2] - ["28" dload-2 2 3] - ["29" dload-3 2 4] - - ["2A" aload-0 1 0] - ["2B" aload-1 1 1] - ["2C" aload-2 1 2] - ["2D" aload-3 1 3]) - (template [ ] - [[ [[local Local]] [local] 0 [[local]]]] - - ["36" istore 1] - ["37" lstore 2] - ["38" fstore 1] - ["39" dstore 2] - ["3A" astore 1]) - (template [ ] - [[ [] [] 0 [[(//unsigned.u1 )]]]] - - ["3B" istore-0 1 0] - ["3C" istore-1 1 1] - ["3D" istore-2 1 2] - ["3E" istore-3 1 3] - - ["3F" lstore-0 2 1] - ["40" lstore-1 2 2] - ["41" lstore-2 2 3] - ["42" lstore-3 2 4] - - ["43" fstore-0 1 0] - ["44" fstore-1 1 1] - ["45" fstore-2 1 2] - ["46" fstore-3 1 3] - - ["47" dstore-0 2 1] - ["48" dstore-1 2 2] - ["49" dstore-2 2 3] - ["4A" dstore-3 2 4] - - ["4B" astore-0 1 0] - ["4C" astore-1 1 1] - ["4D" astore-2 1 2] - ["4E" astore-3 1 3]) - (template [ ] - [[ [] [] 2 []]] - - ["2E" iaload 1] - ["2F" laload 2] - ["30" faload 1] - ["31" daload 2] - ["32" aaload 1] - ["33" baload 1] - ["34" caload 1] - ["35" saload 1]) - (template [ ] - [[ [] [] 0 []]] - - ["4f" iastore 3] - ["50" lastore 4] - ["51" fastore 3] - ["52" dastore 4] - ["53" aastore 3] - ["54" bastore 3] - ["55" castore 3] - ["56" sastore 3]) - (template [ ] - [[ [] [] []]] - - ["60" iadd 2 1] - ["64" isub 2 1] - ["68" imul 2 1] - ["6c" idiv 2 1] - ["70" irem 2 1] - ["74" ineg 1 1] - ["78" ishl 2 1] - ["7a" ishr 2 1] - ["7c" iushr 2 1] - ["7e" iand 2 1] - ["80" ior 2 1] - ["82" ixor 2 1] - - ["61" ladd 4 2] - ["65" lsub 4 2] - ["69" lmul 4 2] - ["6D" ldiv 4 2] - ["71" lrem 4 2] - ["75" lneg 2 2] - ["7F" land 4 2] - ["81" lor 4 2] - ["83" lxor 4 2] - - ["62" fadd 2 1] - ["66" fsub 2 1] - ["6A" fmul 2 1] - ["6E" fdiv 2 1] - ["72" frem 2 1] - ["76" fneg 1 1] - - ["63" dadd 4 2] - ["67" dsub 4 2] - ["6B" dmul 4 2] - ["6F" ddiv 4 2] - ["73" drem 4 2] - ["77" dneg 2 2]) - (template [ ] - [[ [] [] []]] - - ["88" l2i 2 1] - ["89" l2f 2 1] - ["8A" l2d 2 2] - - ["8B" f2i 1 1] - ["8C" f2l 1 2] - ["8D" f2d 1 2] - - ["8E" d2i 2 1] - ["8F" d2l 2 2] - ["90" d2f 2 1] - - ["85" i2l 1 2] - ["86" i2f 1 1] - ["87" i2d 1 2] - ["91" i2b 1 1] - ["92" i2c 1 1] - ["93" i2s 1 1]) - (template [ ] - [[ [] [] 1 []]] - - ["94" lcmp 4] - - ["95" fcmpl 2] - ["96" fcmpg 2] - - ["97" dcmpl 4] - ["98" dcmpg 4]) - (template [ ] - [[ [] [] 0 []]] - - ["AC" ireturn 1] - ["AD" lreturn 2] - ["AE" freturn 1] - ["AF" dreturn 2] - ["B0" areturn 1] - ["B1" return 0] - ) - (template [ ] - [[ [[label Label]] [label] []]] - - ["99" ifeq 2 0] - ["9A" ifne 2 0] - ["9B" iflt 2 0] - ["9C" ifge 2 0] - ["9D" ifgt 2 0] - ["9E" ifle 2 0] - - ["9F" if-icmpeq 2 0] - ["A0" if-icmpne 2 0] - ["A1" if-icmplt 2 0] - ["A2" if-icmpge 2 0] - ["A3" if-icmpgt 2 0] - ["A4" if-icmple 2 0] - - ["A5" if-acmpeq 2 0] - ["A6" if-acmpne 2 0] - - ["A7" goto 0 0] - ["A8" jsr 0 1] - - ["C6" ifnull 1 0] - ["C7" ifnonnull 1 0]) - (template [ ] - [[ [[index (Index (Reference Field))]] [(//index.number index)] []]] - - ["B2" getstatic/1 0 1] ["B2" getstatic/2 0 2] - ["B3" putstatic/1 1 1] ["B3" putstatic/2 1 2] - ["B4" getfield/1 1 1] ["B4" getfield/2 1 2] - ["B5" putfield/1 2 1] ["B5" putfield/2 2 2])] - (template [ ] - [(with-expansions [' (template.splice )] - (template [ ] - [(with-expansions [' (template.splice ) - (template [ ] - [] - - ') - (template [ ] - [] - - ') - ' (template.splice )] - (def: #export ( ) - (-> Instruction) - (..instruction - (`` ($_ /@compose - (/.consumes ) - (/.produces ) - (~~ (template [] - [(/.has-local )] - - ')))) - (`` ( (hex ) (~~ (template.splice )))))))] - - ' - ))] - - [..nullary - [["00" nop [] [] 0 0 []] - - ["57" pop [] [] 1 0 []] - ["58" pop2 [] [] 2 0 []] - ["59" dup [] [] 1 2 []] - ["5A" dup-x1 [] [] 2 3 []] - ["5B" dup-x2 [] [] 3 4 []] - ["5C" dup2 [] [] 2 4 []] - ["5D" dup2-x1 [] [] 3 5 []] - ["5E" dup2-x2 [] [] 4 6 []] - ["5F" swap [] [] 2 2 []] - - - - - - ["79" lshl [] [] 3 2 []] - ["7B" lshr [] [] 3 2 []] - ["7D" lushr [] [] 3 2 []] - - - - ["BE" arraylength [] [] 1 1 []] - ["BF" athrow [] [] 1 0 []] - ["C2" monitorenter [] [] 1 0 []] - ["C3" monitorexit [] [] 1 0 []]]] - - [..unary/1 - [["10" bipush [[byte U1]] [byte] 0 1 []] - ["12" ldc [[index U1]] [index] 0 1 []] - - - ["A9" ret [[local Local]] [local] 0 0 [[local]]] - ["BC" newarray [[type Primitive-Array-Type]] [(..code type)] 1 1 []]]] - - [..unary/2 - [["11" sipush [[short U2]] [short] 0 1 []] - ["13" ldc-w/integer [[index (Index //constant.Integer)]] [(//index.number index)] 0 1 []] - ["13" ldc-w/float [[index (Index //constant.Float)]] [(//index.number index)] 0 1 []] - ["14" ldc2-w/long [[index (Index //constant.Long)]] [(//index.number index)] 0 1 []] - ["14" ldc2-w/double [[index (Index //constant.Double)]] [(//index.number index)] 0 1 []] - - - ["BB" new [[index (Index Class)]] [(//index.number index)] 0 1 []] - ["BD" anewarray [[index (Index Class)]] [(//index.number index)] 1 1 []] - ["C0" checkcast [[index (Index Class)]] [(//index.number index)] 1 1 []] - ["C1" instanceof [[index (Index Class)]] [(//index.number index)] 1 1 []] - ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []] - ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []] - ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]]] - - [..unary/4 - [["C8" goto-w [[label Wide-Label]] [label] 0 0 []] - ["C9" jsr-w [[label Wide-Label]] [label] 0 1 []]]] - - [..binary/11 - [["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]] - - [..binary/21 - [["C5" multianewarray [[index (Index Class)] [count U1]] [(//index.number index) count] (//unsigned.nat count) 1 []]]] - - [..trinary/211 - [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index) count (//unsigned.u1 0)] (//unsigned.nat count) (//unsigned.nat output-count) []]]] - )) - -(structure: #export monoid - (Monoid Instruction) - - (def: identity ..nop) - - (def: (compose left right) - (function (_ input) - (do error.monad - [temp (left input)] - (right temp))))) diff --git a/stdlib/source/lux/target/jvm/code/condition.lux b/stdlib/source/lux/target/jvm/code/condition.lux deleted file mode 100644 index 5769efc79..000000000 --- a/stdlib/source/lux/target/jvm/code/condition.lux +++ /dev/null @@ -1,75 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." exception (#+ exception:)]] - [data - [number (#+ hex)] - ["." error (#+ Error)] - ["." binary] - [text - ["%" format (#+ format)]] - [format - [".F" binary (#+ Mutation Specification)]]]] - ["." // #_ - ["#." resources (#+ Resources)] - ["/#" // #_ - [encoding - ["#." unsigned (#+ U1 U2)]]]]) - -(type: #export Environment - {#resources Resources - #stack U2}) - -(type: #export Condition - (-> Environment (Error Environment))) - -(structure: #export monoid - (Monoid Condition) - - (def: identity (|>> #error.Success)) - - (def: (compose left right) - (function (_ environment) - (do error.monad - [environment (left environment)] - (right environment))))) - -(def: #export (produces amount env) - (-> Nat Condition) - (let [stack (n/+ amount - (///unsigned.nat (get@ #stack env))) - max-stack (n/max stack - (///unsigned.nat (get@ [#resources #//resources.max-stack] env)))] - (|> env - (set@ #stack (///unsigned.u2 stack)) - (set@ [#resources #//resources.max-stack] (///unsigned.u2 max-stack)) - #error.Success))) - -(exception: #export (cannot-pop-stack {stack-size Nat} - {wanted-pops Nat}) - (exception.report - ["Stack Size" (%.nat stack-size)] - ["Wanted Pops" (%.nat wanted-pops)])) - -(def: #export (consumes wanted-pops env) - (-> Nat Condition) - (let [stack-size (///unsigned.nat (get@ #stack env))] - (if (n/<= stack-size wanted-pops) - (#error.Success (update@ #stack - (|>> ///unsigned.nat (n/- wanted-pops) ///unsigned.u2) - env)) - (exception.throw ..cannot-pop-stack [stack-size wanted-pops])))) - -(type: #export Local U1) - -(def: #export (has-local local environment) - (-> Local Condition) - (let [max-locals (n/max (///unsigned.nat (get@ [#resources #//resources.max-locals] environment)) - (///unsigned.nat local))] - (|> environment - (set@ [#resources #//resources.max-locals] - (///unsigned.u2 max-locals)) - #error.Success))) diff --git a/stdlib/source/lux/target/jvm/code/label.lux b/stdlib/source/lux/target/jvm/code/label.lux deleted file mode 100644 index 7aaff5739..000000000 --- a/stdlib/source/lux/target/jvm/code/label.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]]] - ["." /// #_ - [encoding - ["#." unsigned (#+ U2 U4)]]]) - -(type: #export Label U2) - -(def: #export equivalence - ///unsigned.equivalence) - -(def: #export parser - ///unsigned.u2-parser) - -(def: #export writer - ///unsigned.u2-writer) - -(type: #export Wide-Label U4) diff --git a/stdlib/source/lux/target/jvm/code/resources.lux b/stdlib/source/lux/target/jvm/code/resources.lux deleted file mode 100644 index fed6d4ce7..000000000 --- a/stdlib/source/lux/target/jvm/code/resources.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [abstract - ["." equivalence (#+ Equivalence)]] - [control - ["<>" parser - ["<2>" binary (#+ Parser)]]] - [data - [format - [".F" binary (#+ Writer) ("#@." monoid)]]]] - ["." /// #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(type: #export Resources - {#max-stack U2 - #max-locals U2}) - -(def: #export length - ($_ n/+ - ## u2 max_stack; - ///unsigned.u2-bytes - ## u2 max_locals; - ///unsigned.u2-bytes)) - -(def: #export equivalence - (Equivalence Resources) - ($_ equivalence.product - ## u2 max_stack; - ///unsigned.equivalence - ## u2 max_locals; - ///unsigned.equivalence - )) - -(def: #export parser - (Parser Resources) - ($_ <>.and - ## u2 max_stack; - ///unsigned.u2-parser - ## u2 max_locals; - ///unsigned.u2-parser - )) - -(def: #export (writer resources) - (Writer Resources) - ($_ binaryF@compose - ## u2 max_stack; - (///unsigned.u2-writer (get@ #max-stack resources)) - ## u2 max_locals; - (///unsigned.u2-writer (get@ #max-locals resources)) - )) diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux new file mode 100644 index 000000000..9d5dbe06c --- /dev/null +++ b/stdlib/source/lux/target/jvm/program.lux @@ -0,0 +1,99 @@ +(.module: + [lux #* + [abstract + [monoid (#+ Monoid)] + [monad (#+ Monad do)]] + [control + ["." state (#+ State)] + ["." writer (#+ Writer)] + ["." function]] + [data + ["." error (#+ Error)] + [number + ["." nat]] + [collection + ["." dictionary (#+ Dictionary)]]]] + ["." / #_ + ["#." instruction (#+ Instruction) ("#@." monoid)] + [// + [encoding + [unsigned (#+ U2)]]]]) + +(type: #export Label Nat) + +(type: #export Jump U2) + +(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 (Error Instruction))) + +(def: partial-identity + Partial + (function.constant (#error.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 error.monad + [left (left resolver) + right (right resolver)] + (wrap (/instruction@compose left right))))))) + +(type: #export (Program a) + (State Tracker (Writer Partial a))) + +(def: #export new-label + (Program Label) + (function (_ tracker) + [(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) + [..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 Tracker)) + state.monad)))) + +(def: #export (resolve program) + (All [a] (-> (Program a) (Error [Instruction a]))) + (let [[tracker [partial output]] (state.run ..fresh program)] + (do error.monad + [instruction (partial (get@ #known-labels tracker))] + (wrap [instruction output])))) diff --git a/stdlib/source/lux/target/jvm/program/condition.lux b/stdlib/source/lux/target/jvm/program/condition.lux new file mode 100644 index 000000000..5769efc79 --- /dev/null +++ b/stdlib/source/lux/target/jvm/program/condition.lux @@ -0,0 +1,75 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." exception (#+ exception:)]] + [data + [number (#+ hex)] + ["." error (#+ Error)] + ["." binary] + [text + ["%" format (#+ format)]] + [format + [".F" binary (#+ Mutation Specification)]]]] + ["." // #_ + ["#." resources (#+ Resources)] + ["/#" // #_ + [encoding + ["#." unsigned (#+ U1 U2)]]]]) + +(type: #export Environment + {#resources Resources + #stack U2}) + +(type: #export Condition + (-> Environment (Error Environment))) + +(structure: #export monoid + (Monoid Condition) + + (def: identity (|>> #error.Success)) + + (def: (compose left right) + (function (_ environment) + (do error.monad + [environment (left environment)] + (right environment))))) + +(def: #export (produces amount env) + (-> Nat Condition) + (let [stack (n/+ amount + (///unsigned.nat (get@ #stack env))) + max-stack (n/max stack + (///unsigned.nat (get@ [#resources #//resources.max-stack] env)))] + (|> env + (set@ #stack (///unsigned.u2 stack)) + (set@ [#resources #//resources.max-stack] (///unsigned.u2 max-stack)) + #error.Success))) + +(exception: #export (cannot-pop-stack {stack-size Nat} + {wanted-pops Nat}) + (exception.report + ["Stack Size" (%.nat stack-size)] + ["Wanted Pops" (%.nat wanted-pops)])) + +(def: #export (consumes wanted-pops env) + (-> Nat Condition) + (let [stack-size (///unsigned.nat (get@ #stack env))] + (if (n/<= stack-size wanted-pops) + (#error.Success (update@ #stack + (|>> ///unsigned.nat (n/- wanted-pops) ///unsigned.u2) + env)) + (exception.throw ..cannot-pop-stack [stack-size wanted-pops])))) + +(type: #export Local U1) + +(def: #export (has-local local environment) + (-> Local Condition) + (let [max-locals (n/max (///unsigned.nat (get@ [#resources #//resources.max-locals] environment)) + (///unsigned.nat local))] + (|> environment + (set@ [#resources #//resources.max-locals] + (///unsigned.u2 max-locals)) + #error.Success))) diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux new file mode 100644 index 000000000..fcb2c1be7 --- /dev/null +++ b/stdlib/source/lux/target/jvm/program/instruction.lux @@ -0,0 +1,501 @@ +(.module: + [lux (#- Code) + [abstract + [monad (#+ do)] + [monoid (#+ Monoid)]] + [control + ["." exception (#+ exception:)]] + [data + [number (#+ hex)] + ["." error (#+ Error)] + ["." binary] + [text + ["%" format (#+ format)]] + [format + [".F" binary (#+ Mutation Specification)]]] + [macro + ["." template]] + [type + abstract]] + ["." // #_ + ["#." resources (#+ Resources)] + ["/" condition (#+ Environment Condition Local) ("#@." monoid)] + ["#." label (#+ Label Wide-Label)] + ["/#" // #_ + ["#." index (#+ Index)] + ["#." descriptor (#+ Field Method)] + ["#." constant (#+ Class Reference)] + [encoding + ["#." unsigned (#+ U1 U2 U4)]]]]) + +(type: #export Size Nat) + +(type: #export Instruction + [Size (-> [Environment Specification] (Error [Environment Specification]))]) + +(def: (instruction size condition transform) + (-> Size Condition (-> Specification Specification) Instruction) + [size + (function (_ [environment specification]) + (do error.monad + [environment' (condition environment)] + (wrap [environment' + (transform specification)])))]) + +(type: Code Nat) + +(def: (nullary' code) + (-> Code Mutation) + (function (_ [offset binary]) + [(n/+ 1 offset) + (error.assume + (binary.write/8 offset code binary))])) + +(def: (nullary code [size mutation]) + (-> Code (-> Specification Specification)) + [(n/+ 1 size) + (|>> mutation ((nullary' code)))]) + +(def: (unary/1' code input0) + (-> Code U1 Mutation) + (function (_ [offset binary]) + [(n/+ 2 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary)] + (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)))])) + +(def: (unary/1 code input0 [size mutation]) + (-> Code U1 (-> Specification Specification)) + [(n/+ 2 size) + (|>> mutation ((unary/1' code input0)))]) + +(def: (unary/2' code input0) + (-> Code U2 Mutation) + (function (_ [offset binary]) + [(n/+ 3 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary)] + (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))])) + +(def: (unary/2 code input0 [size mutation]) + (-> Code U2 (-> Specification Specification)) + [(n/+ 3 size) + (|>> mutation ((unary/2' code input0)))]) + +(def: (unary/4' code input0) + (-> Code U4 Mutation) + (function (_ [offset binary]) + [(n/+ 5 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary)] + (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))])) + +(def: (unary/4 code input0 [size mutation]) + (-> Code U4 (-> Specification Specification)) + [(n/+ 5 size) + (|>> mutation ((unary/4' code input0)))]) + +(def: (binary/11' code input0 input1) + (-> Code U1 U1 Mutation) + (function (_ [offset binary]) + [(n/+ 3 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary) + _ (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)] + (binary.write/8 (n/+ 2 offset) (///unsigned.nat input1) binary)))])) + +(def: (binary/11 code input0 input1 [size mutation]) + (-> Code U1 U1 (-> Specification Specification)) + [(n/+ 3 size) + (|>> mutation ((binary/11' code input0 input1)))]) + +(def: (binary/21' code input0 input1) + (-> Code U2 U1 Mutation) + (function (_ [offset binary]) + [(n/+ 4 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary) + _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)] + (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)))])) + +(def: (binary/21 code input0 input1 [size mutation]) + (-> Code U2 U1 (-> Specification Specification)) + [(n/+ 4 size) + (|>> mutation ((binary/21' code input0 input1)))]) + +(def: (trinary/211' code input0 input1 input2) + (-> Code U2 U1 U1 Mutation) + (function (_ [offset binary]) + [(n/+ 5 offset) + (error.assume + (do error.monad + [_ (binary.write/8 offset code binary) + _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary) + _ (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)] + (binary.write/8 (n/+ 4 offset) (///unsigned.nat input2) binary)))])) + +(def: (trinary/211 code input0 input1 input2 [size mutation]) + (-> Code U2 U1 U1 (-> Specification Specification)) + [(n/+ 5 size) + (|>> mutation ((trinary/211' code input0 input1 input2)))]) + +(abstract: #export Primitive-Array-Type + {} + + U1 + + (def: code + (-> Primitive-Array-Type U1) + (|>> :representation)) + + (template [ ] + [(def: #export (|> ///unsigned.u1 :abstraction))] + + [04 t-boolean] + [05 t-char] + [06 t-float] + [07 t-double] + [08 t-byte] + [09 t-short] + [10 t-int] + [11 t-long] + )) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 +(with-expansions [ (template [ ] + [[ [] [] 0 []]] + + ["01" aconst-null 1] + + ["02" iconst-m1 1] + ["03" iconst-0 1] + ["04" iconst-1 1] + ["05" iconst-2 1] + ["06" iconst-3 1] + ["07" iconst-4 1] + ["08" iconst-5 1] + + ["09" lconst-0 2] + ["0A" lconst-1 2] + + ["0B" fconst-0 1] + ["0C" fconst-1 1] + ["0D" fconst-2 1] + + ["0E" dconst-0 2] + ["0F" dconst-1 2]) + (template [ ] + [[ [[local Local]] [local] 0 [[local]]]] + + ["15" iload 1] + ["16" lload 2] + ["17" fload 1] + ["18" dload 2] + ["19" aload 1]) + (template [ ] + [[ [] [] 0 [[(///unsigned.u1 )]]]] + + ["1A" iload-0 1 0] + ["1B" iload-1 1 1] + ["1C" iload-2 1 2] + ["1D" iload-3 1 3] + + ["1E" lload-0 2 1] + ["1F" lload-1 2 2] + ["20" lload-2 2 3] + ["21" lload-3 2 4] + + ["22" fload-0 1 0] + ["23" fload-1 1 1] + ["24" fload-2 1 2] + ["25" fload-3 1 3] + + ["26" dload-0 2 1] + ["27" dload-1 2 2] + ["28" dload-2 2 3] + ["29" dload-3 2 4] + + ["2A" aload-0 1 0] + ["2B" aload-1 1 1] + ["2C" aload-2 1 2] + ["2D" aload-3 1 3]) + (template [ ] + [[ [[local Local]] [local] 0 [[local]]]] + + ["36" istore 1] + ["37" lstore 2] + ["38" fstore 1] + ["39" dstore 2] + ["3A" astore 1]) + (template [ ] + [[ [] [] 0 [[(///unsigned.u1 )]]]] + + ["3B" istore-0 1 0] + ["3C" istore-1 1 1] + ["3D" istore-2 1 2] + ["3E" istore-3 1 3] + + ["3F" lstore-0 2 1] + ["40" lstore-1 2 2] + ["41" lstore-2 2 3] + ["42" lstore-3 2 4] + + ["43" fstore-0 1 0] + ["44" fstore-1 1 1] + ["45" fstore-2 1 2] + ["46" fstore-3 1 3] + + ["47" dstore-0 2 1] + ["48" dstore-1 2 2] + ["49" dstore-2 2 3] + ["4A" dstore-3 2 4] + + ["4B" astore-0 1 0] + ["4C" astore-1 1 1] + ["4D" astore-2 1 2] + ["4E" astore-3 1 3]) + (template [ ] + [[ [] [] 2 []]] + + ["2E" iaload 1] + ["2F" laload 2] + ["30" faload 1] + ["31" daload 2] + ["32" aaload 1] + ["33" baload 1] + ["34" caload 1] + ["35" saload 1]) + (template [ ] + [[ [] [] 0 []]] + + ["4f" iastore 3] + ["50" lastore 4] + ["51" fastore 3] + ["52" dastore 4] + ["53" aastore 3] + ["54" bastore 3] + ["55" castore 3] + ["56" sastore 3]) + (template [ ] + [[ [] [] []]] + + ["60" iadd 2 1] + ["64" isub 2 1] + ["68" imul 2 1] + ["6c" idiv 2 1] + ["70" irem 2 1] + ["74" ineg 1 1] + ["78" ishl 2 1] + ["7a" ishr 2 1] + ["7c" iushr 2 1] + ["7e" iand 2 1] + ["80" ior 2 1] + ["82" ixor 2 1] + + ["61" ladd 4 2] + ["65" lsub 4 2] + ["69" lmul 4 2] + ["6D" ldiv 4 2] + ["71" lrem 4 2] + ["75" lneg 2 2] + ["7F" land 4 2] + ["81" lor 4 2] + ["83" lxor 4 2] + + ["62" fadd 2 1] + ["66" fsub 2 1] + ["6A" fmul 2 1] + ["6E" fdiv 2 1] + ["72" frem 2 1] + ["76" fneg 1 1] + + ["63" dadd 4 2] + ["67" dsub 4 2] + ["6B" dmul 4 2] + ["6F" ddiv 4 2] + ["73" drem 4 2] + ["77" dneg 2 2]) + (template [ ] + [[ [] [] []]] + + ["88" l2i 2 1] + ["89" l2f 2 1] + ["8A" l2d 2 2] + + ["8B" f2i 1 1] + ["8C" f2l 1 2] + ["8D" f2d 1 2] + + ["8E" d2i 2 1] + ["8F" d2l 2 2] + ["90" d2f 2 1] + + ["85" i2l 1 2] + ["86" i2f 1 1] + ["87" i2d 1 2] + ["91" i2b 1 1] + ["92" i2c 1 1] + ["93" i2s 1 1]) + (template [ ] + [[ [] [] 1 []]] + + ["94" lcmp 4] + + ["95" fcmpl 2] + ["96" fcmpg 2] + + ["97" dcmpl 4] + ["98" dcmpg 4]) + (template [ ] + [[ [] [] 0 []]] + + ["AC" ireturn 1] + ["AD" lreturn 2] + ["AE" freturn 1] + ["AF" dreturn 2] + ["B0" areturn 1] + ["B1" return 0] + ) + (template [ ] + [[ [[label Label]] [label] []]] + + ["99" ifeq 2 0] + ["9A" ifne 2 0] + ["9B" iflt 2 0] + ["9C" ifge 2 0] + ["9D" ifgt 2 0] + ["9E" ifle 2 0] + + ["9F" if-icmpeq 2 0] + ["A0" if-icmpne 2 0] + ["A1" if-icmplt 2 0] + ["A2" if-icmpge 2 0] + ["A3" if-icmpgt 2 0] + ["A4" if-icmple 2 0] + + ["A5" if-acmpeq 2 0] + ["A6" if-acmpne 2 0] + + ["A7" goto 0 0] + ["A8" jsr 0 1] + + ["C6" ifnull 1 0] + ["C7" ifnonnull 1 0]) + (template [ ] + [[ [[index (Index (Reference Field))]] [(///index.number index)] []]] + + ["B2" getstatic/1 0 1] ["B2" getstatic/2 0 2] + ["B3" putstatic/1 1 1] ["B3" putstatic/2 1 2] + ["B4" getfield/1 1 1] ["B4" getfield/2 1 2] + ["B5" putfield/1 2 1] ["B5" putfield/2 2 2])] + (template [ ] + [(with-expansions [' (template.splice )] + (template [ ] + [(with-expansions [' (template.splice ) + (template [ ] + [] + + ') + (template [ ] + [] + + ') + ' (template.splice )] + (def: #export ( ) + (-> Instruction) + (..instruction + + (`` ($_ /@compose + (/.consumes ) + (/.produces ) + (~~ (template [] + [(/.has-local )] + + ')))) + (`` ( (hex ) (~~ (template.splice )))))))] + + ' + ))] + + [..nullary 1 + [["00" nop [] [] 0 0 []] + + ["57" pop [] [] 1 0 []] + ["58" pop2 [] [] 2 0 []] + ["59" dup [] [] 1 2 []] + ["5A" dup-x1 [] [] 2 3 []] + ["5B" dup-x2 [] [] 3 4 []] + ["5C" dup2 [] [] 2 4 []] + ["5D" dup2-x1 [] [] 3 5 []] + ["5E" dup2-x2 [] [] 4 6 []] + ["5F" swap [] [] 2 2 []] + + + + + + ["79" lshl [] [] 3 2 []] + ["7B" lshr [] [] 3 2 []] + ["7D" lushr [] [] 3 2 []] + + + + ["BE" arraylength [] [] 1 1 []] + ["BF" athrow [] [] 1 0 []] + ["C2" monitorenter [] [] 1 0 []] + ["C3" monitorexit [] [] 1 0 []]]] + + [..unary/1 2 + [["10" bipush [[byte U1]] [byte] 0 1 []] + ["12" ldc [[index U1]] [index] 0 1 []] + + + ["A9" ret [[local Local]] [local] 0 0 [[local]]] + ["BC" newarray [[type Primitive-Array-Type]] [(..code type)] 1 1 []]]] + + [..unary/2 3 + [["11" sipush [[short U2]] [short] 0 1 []] + ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []] + ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []] + ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 1 []] + ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 1 []] + + + ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []] + ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []] + ["C0" checkcast [[index (Index Class)]] [(///index.number index)] 1 1 []] + ["C1" instanceof [[index (Index Class)]] [(///index.number index)] 1 1 []] + ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []] + ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []] + ["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 []]]] + + [..binary/11 3 + [["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]] + + [..binary/21 4 + [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.number index) count] (///unsigned.nat count) 1 []]]] + + [..trinary/211 5 + [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index) count (///unsigned.u1 0)] (///unsigned.nat count) (///unsigned.nat output-count) []]]] + )) + +(structure: #export monoid + (Monoid Instruction) + + (def: identity ..nop) + + (def: (compose [left-size left] [right-size right]) + [(n/+ left-size right-size) + (function (_ input) + (do error.monad + [temp (left input)] + (right temp)))])) diff --git a/stdlib/source/lux/target/jvm/program/label.lux b/stdlib/source/lux/target/jvm/program/label.lux new file mode 100644 index 000000000..7aaff5739 --- /dev/null +++ b/stdlib/source/lux/target/jvm/program/label.lux @@ -0,0 +1,20 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)]]] + ["." /// #_ + [encoding + ["#." unsigned (#+ U2 U4)]]]) + +(type: #export Label U2) + +(def: #export equivalence + ///unsigned.equivalence) + +(def: #export parser + ///unsigned.u2-parser) + +(def: #export writer + ///unsigned.u2-writer) + +(type: #export Wide-Label U4) diff --git a/stdlib/source/lux/target/jvm/program/resources.lux b/stdlib/source/lux/target/jvm/program/resources.lux new file mode 100644 index 000000000..fed6d4ce7 --- /dev/null +++ b/stdlib/source/lux/target/jvm/program/resources.lux @@ -0,0 +1,51 @@ +(.module: + [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] + [control + ["<>" parser + ["<2>" binary (#+ Parser)]]] + [data + [format + [".F" binary (#+ Writer) ("#@." monoid)]]]] + ["." /// #_ + [encoding + ["#." unsigned (#+ U2)]]]) + +(type: #export Resources + {#max-stack U2 + #max-locals U2}) + +(def: #export length + ($_ n/+ + ## u2 max_stack; + ///unsigned.u2-bytes + ## u2 max_locals; + ///unsigned.u2-bytes)) + +(def: #export equivalence + (Equivalence Resources) + ($_ equivalence.product + ## u2 max_stack; + ///unsigned.equivalence + ## u2 max_locals; + ///unsigned.equivalence + )) + +(def: #export parser + (Parser Resources) + ($_ <>.and + ## u2 max_stack; + ///unsigned.u2-parser + ## u2 max_locals; + ///unsigned.u2-parser + )) + +(def: #export (writer resources) + (Writer Resources) + ($_ binaryF@compose + ## u2 max_stack; + (///unsigned.u2-writer (get@ #max-stack resources)) + ## u2 max_locals; + (///unsigned.u2-writer (get@ #max-locals resources)) + )) -- cgit v1.2.3