From 46e037ea7e88c8b058311ee384f0aa81582028c5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 5 Jul 2019 22:44:24 -0400 Subject: WIP: Method compilation. --- stdlib/source/lux/data/format/binary.lux | 9 ++-- stdlib/source/lux/target/jvm/class.lux | 17 ++++--- stdlib/source/lux/target/jvm/constant.lux | 2 +- stdlib/source/lux/target/jvm/constant/pool.lux | 57 ++++++++++++++++------ stdlib/source/lux/target/jvm/descriptor.lux | 11 +++-- stdlib/source/lux/target/jvm/method.lux | 20 ++++++-- stdlib/source/lux/target/jvm/program.lux | 46 +++++++++++++++-- stdlib/source/lux/target/jvm/program/condition.lux | 5 ++ .../source/lux/target/jvm/program/instruction.lux | 5 ++ stdlib/source/lux/target/jvm/program/resources.lux | 5 ++ 10 files changed, 138 insertions(+), 39 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index d7abd617c..5e35829c8 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -33,12 +33,16 @@ (-> [Offset Binary] [Offset Binary])) (type: #export Specification - [Size (-> [Offset Binary] [Offset Binary])]) + [Size Mutation]) (def: #export no-op Specification [0 function.identity]) +(def: #export (instance [size mutation]) + (-> Specification Binary) + (|> size binary.create [0] mutation product.right)) + (structure: #export monoid (Monoid Specification) (def: identity @@ -53,8 +57,7 @@ (def: #export (run writer value) (All [a] (-> (Writer a) a Binary)) - (let [[valueS valueT] (writer value)] - (|> valueS binary.create [0] valueT product.right))) + (instance (writer value))) (template [ ] [(def: #export diff --git a/stdlib/source/lux/target/jvm/class.lux b/stdlib/source/lux/target/jvm/class.lux index 516dec1fc..a99637dcd 100644 --- a/stdlib/source/lux/target/jvm/class.lux +++ b/stdlib/source/lux/target/jvm/class.lux @@ -74,12 +74,12 @@ (-> Internal Internal (List Internal) (State Pool [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) (do state.monad - [@this (//constant/pool.class (//name.read this)) - @super (//constant/pool.class (//name.read super)) + [@this (//constant/pool.class this) + @super (//constant/pool.class super) @interfaces (: (State Pool (Row (Index //constant.Class))) (monad.fold @ (function (_ interface @interfaces) (do @ - [@interface (//constant/pool.class (//name.read interface))] + [@interface (//constant/pool.class interface)] (wrap (row.add @interface @interfaces)))) row.empty interfaces))] @@ -91,15 +91,16 @@ (-> Major (Modifier Class) Internal Internal (List Internal) (List (State Pool Field)) - (Row Method) + (List (State Pool Method)) (Row Attribute) Class) - (let [[pool [@this @super @interfaces] =fields] + (let [[pool [@this @super @interfaces] =fields =methods] (state.run //constant/pool.empty (do state.monad [classes (install-classes this super interfaces) - =fields (monad.seq state.monad fields)] - (wrap [classes =fields])))] + =fields (monad.seq state.monad fields) + =methods (monad.seq state.monad methods)] + (wrap [classes =fields =methods])))] {#magic //magic.code #minor-version //version.default-minor #major-version version @@ -109,7 +110,7 @@ #super @super #interfaces @interfaces #fields (row.from-list =fields) - #methods methods + #methods (row.from-list =methods) #attributes attributes})) (def: #export parser diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux index 31dfe3bbb..36c131b00 100644 --- a/stdlib/source/lux/target/jvm/constant.lux +++ b/stdlib/source/lux/target/jvm/constant.lux @@ -114,7 +114,7 @@ #name-and-type (Index (Name-And-Type of))}) (template [ ] - [(def: + [(def: #export (Equivalence ( Any)) ($_ equivalence.product //index.equivalence diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux index dc500c885..5d8636deb 100644 --- a/stdlib/source/lux/target/jvm/constant/pool.lux +++ b/stdlib/source/lux/target/jvm/constant/pool.lux @@ -24,12 +24,13 @@ abstract] [macro ["." template]]] - ["." // (#+ UTF8 Class Long Double Constant) + ["." // (#+ UTF8 Class Long Double Constant Name-And-Type Reference) [// [encoding - ["." unsigned]] - ["." index (#+ Index)] - ["." descriptor (#+ Descriptor)]]]) + ["#." name (#+ Internal External)] + ["#." unsigned]] + ["#." index (#+ Index)] + ["#." descriptor (#+ Field Method Descriptor)]]]) (def: offset 1) @@ -41,7 +42,7 @@ (template: (!add <=> ) (function (_ pool) - (with-expansions [ (as-is (index.index (unsigned.u2 (n/+ offset idx)))) + (with-expansions [ (as-is (//index.index (//unsigned.u2 (n/+ offset idx)))) (as-is (recur (.inc idx)))] (loop [idx 0] (case (row.nth idx pool) @@ -61,7 +62,7 @@ ]))))) (template: (!raw-index ) - (|> index.number unsigned.nat .nat)) + (|> //index.number //unsigned.nat .nat)) (exception: #export (invalid-index {index (Index Any)} {maximum Nat}) @@ -97,7 +98,7 @@ (template: (!find <=> <%> ) (function (_ pool) - (with-expansions [ (as-is (index.index (unsigned.u2 (n/+ offset idx)))) + (with-expansions [ (as-is (//index.index (//unsigned.u2 (n/+ offset idx)))) (as-is (recur (.inc idx)))] (loop [idx 0] (case (row.nth idx pool) @@ -143,23 +144,49 @@ [utf8 UTF8 #//.UTF8 text.equivalence %.text] ) -(def: (class' value) - (Adder Class) - (!add #//.Class //.class-equivalence value)) - (def: #export (class name) - (-> UTF8 (State Pool (Index Class))) + (-> Internal (State Pool (Index Class))) (do state.monad - [@name (utf8 name)] - (class' (//.class @name)))) + [@name (utf8 (//name.read name)) + #let [value (//.class @name)]] + (!add #//.Class //.class-equivalence value))) (def: #export (descriptor value) (All [kind] (-> (Descriptor kind) (State Pool (Index (Descriptor kind))))) - (let [value (descriptor.descriptor value)] + (let [value (//descriptor.descriptor value)] (!add #//.UTF8 text.equivalence value))) +(type: #export (Member of) + {#name UTF8 + #descriptor (Descriptor of)}) + +(def: #export (name-and-type [name descriptor]) + (All [of] + (-> (Member of) (State Pool (Index (Name-And-Type of))))) + (do state.monad + [@name (utf8 name) + @descriptor (..descriptor descriptor)] + (!add #//.Name-And-Type //.name-and-type-equivalence + {#//.name @name + #//.descriptor @descriptor}))) + +(template [ ] + [(def: #export ( class member) + (-> External (Member ) (State Pool (Index (Reference )))) + (do state.monad + [@class (..class (//name.internal class)) + @name-and-type (name-and-type member)] + (!add //.reference-equivalence + {#//.class @class + #//.name-and-type @name-and-type})))] + + [field #//.Field Field] + [method #//.Method Method] + [interface-method #//.Interface-Method Method] + ) + (def: #export parser (Parser Pool) (<2>.row/16' ..offset //.parser)) diff --git a/stdlib/source/lux/target/jvm/descriptor.lux b/stdlib/source/lux/target/jvm/descriptor.lux index c0cb20a61..1ca625bd6 100644 --- a/stdlib/source/lux/target/jvm/descriptor.lux +++ b/stdlib/source/lux/target/jvm/descriptor.lux @@ -4,14 +4,14 @@ ["." text ["%" format (#+ format)]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] [macro ["." template]] [type abstract]] ["." // #_ [encoding - ["#." name (#+ Internal)]]]) + ["#." name (#+ External)]]]) (abstract: #export Void' {} Any) @@ -57,8 +57,9 @@ ) (def: #export object - (-> Internal (Descriptor Object)) - (|>> //name.read + (-> External (Descriptor Object)) + (|>> //name.internal + //name.read (text.enclose ["L" ";"]) :abstraction)) @@ -75,7 +76,7 @@ (Descriptor Method)) (:abstraction (format (|> inputs - (list;map (|>> :representation)) + (list@map (|>> :representation)) (text.join-with "") (text.enclose ["(" ")"])) (:representation output)))) diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux index e6ee82617..d081d1c81 100644 --- a/stdlib/source/lux/target/jvm/method.lux +++ b/stdlib/source/lux/target/jvm/method.lux @@ -1,13 +1,13 @@ (.module: [lux (#- static) [abstract - ["." equivalence (#+ Equivalence)] [monoid (#+)] + ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control + ["." state (#+ State)] ["<>" parser - ["<2>" binary (#+ Parser)]] - ["." state (#+ State)]] + ["<2>" binary (#+ Parser)]]] [data [number (#+) [i64 (#+)]] @@ -23,7 +23,7 @@ ["#." attribute (#+ Attribute)] ["#." descriptor (#+ Descriptor)] ["#." constant (#+ UTF8) - [pool (#+ Pool)]]]) + ["#/." pool (#+ Pool)]]]) (type: #export #rec Method {#modifier (Modifier Method) @@ -46,6 +46,18 @@ ["1000" synthetic] ) +(def: #export (method modifier name descriptor attributes) + (-> (Modifier Method) UTF8 (Descriptor //descriptor.Method) (List (State Pool Attribute)) + (State Pool Method)) + (do state.monad + [@name (//constant/pool.utf8 name) + @descriptor (//constant/pool.descriptor descriptor) + attributes (monad.seq @ attributes)] + (wrap {#modifier modifier + #name @name + #descriptor @descriptor + #attributes (row.from-list attributes)}))) + (def: #export equivalence (Equivalence Method) ($_ equivalence.product diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux index 61e5a9046..fd786d619 100644 --- a/stdlib/source/lux/target/jvm/program.lux +++ b/stdlib/source/lux/target/jvm/program.lux @@ -15,6 +15,7 @@ [number ["." nat]] [collection + ["." list ("#@." functor fold)] ["." dictionary (#+ Dictionary)]]]] ["." / #_ ["#." condition (#+ Local)] @@ -22,7 +23,9 @@ ["#." instruction (#+ Primitive-Array-Type Instruction) ("#@." monoid)] ["/#" // #_ ["#." index] + ["#." descriptor (#+ Descriptor Value Return)] [encoding + ["#." name (#+ External)] ["#." unsigned (#+ U1 U2)] ["#." signed]] ["#." constant (#+ UTF8) @@ -428,7 +431,7 @@ (-> UTF8 (Program Any)) (do ..monad ## TODO: Make sure it"s impossible to have indexes greater than U2. - [index (..lift (//constant/pool.class class))] + [index (..lift (//constant/pool.class (//name.internal class)))] (..nullary ( index))))] [new /instruction.new] @@ -442,7 +445,44 @@ (..nullary (/instruction.iinc register increase))) (def: #export (multianewarray class count) - (-> UTF8 U1 (Program Any)) + (-> External U1 (Program Any)) (do ..monad - [index (..lift (//constant/pool.class class))] + [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 [ ] + [(def: #export ( 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)})] + (wrap (/instruction.invokestatic + index + (|> inputs + (list@map descriptor-size) + (list@fold //unsigned.u1/+ (//unsigned.u1 0)) + (//unsigned.u1/+ (//unsigned.u1 (if 0 1)))) + (descriptor-size output)))))] + + [#1 invokestatic /instruction.invokestatic] + [#0 invokevirtual /instruction.invokevirtual] + [#0 invokespecial /instruction.invokespecial] + [#0 invokeinterface /instruction.invokeinterface] + ) diff --git a/stdlib/source/lux/target/jvm/program/condition.lux b/stdlib/source/lux/target/jvm/program/condition.lux index e0b778c07..04bb8c60b 100644 --- a/stdlib/source/lux/target/jvm/program/condition.lux +++ b/stdlib/source/lux/target/jvm/program/condition.lux @@ -23,6 +23,11 @@ {#resources Resources #stack U2}) +(def: #export start + Environment + {#resources //resources.start + #stack (///unsigned.u2 0)}) + (type: #export Condition (-> Environment (Try Environment))) diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux index 375204cc8..3d0397a14 100644 --- a/stdlib/source/lux/target/jvm/program/instruction.lux +++ b/stdlib/source/lux/target/jvm/program/instruction.lux @@ -34,6 +34,11 @@ (type: #export Instruction [Size (-> [Environment Specification] (Try [Environment Specification]))]) +(def: #export (run instruction) + (-> Instruction (Try [Environment Specification])) + (let [[_ instruction'] instruction] + (instruction' [/.start binaryF.no-op]))) + (def: (instruction size condition transform) (-> Size Condition (-> Specification Specification) Instruction) [size diff --git a/stdlib/source/lux/target/jvm/program/resources.lux b/stdlib/source/lux/target/jvm/program/resources.lux index fed6d4ce7..980104e72 100644 --- a/stdlib/source/lux/target/jvm/program/resources.lux +++ b/stdlib/source/lux/target/jvm/program/resources.lux @@ -16,6 +16,11 @@ {#max-stack U2 #max-locals U2}) +(def: #export start + Resources + {#max-stack (///unsigned.u2 0) + #max-locals (///unsigned.u2 0)}) + (def: #export length ($_ n/+ ## u2 max_stack; -- cgit v1.2.3