diff options
Diffstat (limited to 'lux-jvm/source')
| -rw-r--r-- | lux-jvm/source/luxc/lang/directive/jvm.lux | 40 | ||||
| -rw-r--r-- | lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux | 94 | ||||
| -rw-r--r-- | lux-jvm/source/luxc/lang/translation/jvm/function.lux | 34 | ||||
| -rw-r--r-- | lux-jvm/source/program.lux | 125 |
4 files changed, 223 insertions, 70 deletions
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 4d5d88548..7b3235c06 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -369,7 +369,7 @@ (#/.Return instruction) (..return instruction))) (def: (instruction instruction) - (-> (/.Instruction org/objectweb/asm/Label) Inst) + (-> (/.Instruction Inst org/objectweb/asm/Label) Inst) (case instruction #/.NOP _.NOP (#/.Constant instruction) (..constant instruction) @@ -381,7 +381,8 @@ (#/.Local instruction) (..local instruction) (#/.Stack instruction) (..stack instruction) (#/.Comparison instruction) (..comparison instruction) - (#/.Control instruction) (..control instruction))) + (#/.Control instruction) (..control instruction) + (#/.Embedded embedded) embedded)) (type: Mapping (Dictionary /.Label org/objectweb/asm/Label)) @@ -460,9 +461,13 @@ )) (def: (relabel_instruction [mapping instruction]) - (Re_labeler /.Instruction) + (Re_labeler (/.Instruction Inst)) (case instruction - #/.NOP [mapping #/.NOP] + (#/.Embedded embedded) + [mapping (#/.Embedded embedded)] + + #/.NOP + [mapping #/.NOP] (^template [<tag>] [(<tag> instruction) @@ -482,10 +487,10 @@ [mapping (#/.Control instruction)]))) (def: (relabel_bytecode [mapping bytecode]) - (Re_labeler /.Bytecode) + (Re_labeler (/.Bytecode Inst)) (row@fold (function (_ input [mapping output]) - (let [[mapping input] (..relabel_instruction [mapping input])] - [mapping (row.add input output)])) + (let [[mapping input'] (..relabel_instruction [mapping input])] + [mapping (row.add input' output)])) [mapping (row.row)] bytecode)) @@ -494,7 +499,7 @@ (dictionary.new nat.hash)) (def: bytecode - (-> (/.Bytecode /.Label) jvm.Inst) + (-> (/.Bytecode Inst /.Label) jvm.Inst) (|>> [..fresh] ..relabel_bytecode product.right @@ -502,15 +507,28 @@ row.to_list _.fuse)) -(type: Handler - (generation.Handler jvm.Anchor (/.Bytecode /.Label) jvm.Definition)) +(with_expansions [<anchor> (as_is jvm.Anchor) + <expression> (as_is Inst) + <directive> (as_is jvm.Definition) + <type_vars> (as_is <anchor> <expression> <directive>)] + (type: Handler + ## (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) + (-> extension.Name + (phase.Phase [(extension.Bundle <type_vars>) + (generation.State <type_vars>)] + Synthesis + <expression>) + (phase.Phase [(extension.Bundle <type_vars>) + (generation.State <type_vars>)] + (List Synthesis) + (/.Bytecode Inst /.Label))))) (def: (true_handler extender pseudo) (-> jvm.Extender Any jvm.Handler) (function (_ extension_name phase archive inputs) (do phase.monad [bytecode ((extender pseudo) extension_name phase archive inputs)] - (wrap (..bytecode (:coerce (/.Bytecode /.Label) bytecode)))))) + (wrap (..bytecode (:coerce (/.Bytecode Inst /.Label) bytecode)))))) (def: (def::generation extender) (-> jvm.Extender diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index dc579c970..96fa95363 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -7,8 +7,8 @@ ["." exception (#+ exception:)] ["." function] ["<>" parser ("#@." monad) - ["<t>" text] - ["<s>" synthesis (#+ Parser)]]] + ["<.>" text] + ["<.>" synthesis (#+ Parser)]]] [data ["." product] ["." maybe ("#@." functor)] @@ -66,7 +66,7 @@ (template [<name> <category> <parser>] [(def: #export <name> (Parser (Type <category>)) - (<t>.embed <parser> <s>.text))] + (<text>.embed <parser> <synthesis>.text))] [var Var parser.var] [class Class parser.class] @@ -82,7 +82,7 @@ (def: #export object_array (Parser (Type Object)) (do <>.monad - [arrayJT (<t>.embed parser.array <s>.text)] + [arrayJT (<text>.embed parser.array <synthesis>.text)] (case (parser.array? arrayJT) (#.Some elementJT) (case (parser.object? elementJT) @@ -339,7 +339,7 @@ (def: (primitive_array_length_handler jvm_primitive) (-> (Type Primitive) Handler) (..custom - [<s>.any + [<synthesis>.any (function (_ extension_name generate archive arrayS) (do phase.monad [arrayI (generate archive arrayS)] @@ -350,7 +350,7 @@ (def: array::length::object Handler (..custom - [($_ <>.and ..object_array <s>.any) + [($_ <>.and ..object_array <synthesis>.any) (function (_ extension_name generate archive [elementJT arrayS]) (do phase.monad [arrayI (generate archive arrayS)] @@ -374,7 +374,7 @@ (def: array::new::object Handler (..custom - [($_ <>.and ..object <s>.any) + [($_ <>.and ..object <synthesis>.any) (function (_ extension_name generate archive [objectJT lengthS]) (do phase.monad [lengthI (generate archive lengthS)] @@ -400,7 +400,7 @@ (def: array::read::object Handler (..custom - [($_ <>.and ..object_array <s>.any <s>.any) + [($_ <>.and ..object_array <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [elementJT idxS arrayS]) (do phase.monad [arrayI (generate archive arrayS) @@ -432,7 +432,7 @@ (def: array::write::object Handler (..custom - [($_ <>.and ..object_array <s>.any <s>.any <s>.any) + [($_ <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [elementJT idxS valueS arrayS]) (do phase.monad [arrayI (generate archive arrayS) @@ -525,7 +525,8 @@ (|>> exceptionI _.ATHROW)) -(def: $Class (type.class "java.lang.Class" (list))) +(def: $Class + (type.class "java.lang.Class" (list))) (def: (object::class extension_name generate archive inputs) Handler @@ -542,7 +543,7 @@ (def: object::instance? Handler (..custom - [($_ <>.and <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class objectS]) (do phase.monad [objectI (generate archive objectS)] @@ -611,7 +612,7 @@ (def: get::static Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text) (function (_ extension_name generate archive [class field unboxed]) (do phase.monad [] @@ -625,7 +626,7 @@ (def: put::static Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class field unboxed valueS]) (do phase.monad [valueI (generate archive valueS) @@ -645,7 +646,7 @@ (def: get::virtual Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class field unboxed objectS]) (do phase.monad [objectI (generate archive objectS) @@ -663,7 +664,7 @@ (def: put::virtual Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [class field unboxed valueS objectS]) (do phase.monad [valueI (generate archive valueS) @@ -683,11 +684,12 @@ valueI putI))))])) -(type: Input (Typed Synthesis)) +(type: Input + (Typed Synthesis)) (def: input (Parser Input) - (<s>.tuple (<>.and ..value <s>.any))) + (<synthesis>.tuple (<>.and ..value <synthesis>.any))) (def: (generate_input generate archive [valueT valueS]) (-> Phase Archive Input @@ -702,7 +704,8 @@ (wrap [valueT (|>> valueI (_.CHECKCAST valueT))])))) -(def: voidI (_.string synthesis.unit)) +(def: voidI + (_.string synthesis.unit)) (def: (prepare_output outputT) (-> (Type Return) Inst) @@ -716,7 +719,7 @@ (def: invoke::static Handler (..custom - [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + [($_ <>.and ..class <synthesis>.text ..return (<>.some ..input)) (function (_ extension_name generate archive [class method outputT inputsTS]) (do {@ phase.monad} [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] @@ -728,7 +731,7 @@ [(def: <name> Handler (..custom - [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input)) (function (_ extension_name generate archive [class method outputT objectS inputsTS]) (do {@ phase.monad} [objectI (generate archive objectS) @@ -782,37 +785,38 @@ (def: annotation_parameter (Parser (/.Annotation_Parameter Synthesis)) - (<s>.tuple (<>.and <s>.text <s>.any))) + (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any))) (def: annotation (Parser (/.Annotation Synthesis)) - (<s>.tuple (<>.and <s>.text (<>.some ..annotation_parameter)))) + (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter)))) (def: argument (Parser Argument) - (<s>.tuple (<>.and <s>.text ..value))) + (<synthesis>.tuple (<>.and <synthesis>.text ..value))) (def: overriden_method_definition (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) - (<s>.tuple (do <>.monad - [_ (<s>.text! /.overriden_tag) - ownerT ..class - name <s>.text - strict_fp? <s>.bit - annotations (<s>.tuple (<>.some ..annotation)) - vars (<s>.tuple (<>.some ..var)) - self_name <s>.text - arguments (<s>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<s>.tuple (<>.some ..class)) - [environment _ _ body] (<s>.function 1 - (<s>.loop (<>.exactly 0 <s>.any) - (<s>.tuple <s>.any)))] - (wrap [environment - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - body]])))) + (<synthesis>.tuple + (do <>.monad + [_ (<synthesis>.text! /.overriden_tag) + ownerT ..class + name <synthesis>.text + strict_fp? <synthesis>.bit + annotations (<synthesis>.tuple (<>.some ..annotation)) + vars (<synthesis>.tuple (<>.some ..var)) + self_name <synthesis>.text + arguments (<synthesis>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<synthesis>.tuple (<>.some ..class)) + [environment _ _ body] (<synthesis>.function 1 + (<synthesis>.loop (<>.exactly 0 <synthesis>.any) + (<synthesis>.tuple <synthesis>.any)))] + (wrap [environment + [ownerT name + strict_fp? annotations vars + self_name arguments returnT exceptionsT + body]])))) (def: (normalize_path normalize) (-> (-> Synthesis Synthesis) @@ -978,9 +982,9 @@ (..custom [($_ <>.and ..class - (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..input)) - (<s>.tuple (<>.some ..overriden_method_definition))) + (<synthesis>.tuple (<>.some ..class)) + (<synthesis>.tuple (<>.some ..input)) + (<synthesis>.tuple (<>.some ..overriden_method_definition))) (function (_ extension_name generate archive [super_class super_interfaces inputsTS overriden_methods]) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux index 0b441c92f..a3583155b 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -30,7 +30,7 @@ [lux [analysis (#+ Environment)] [synthesis (#+ Synthesis Abstraction Apply)] - ["." generation]]] + ["." generation (#+ Context)]]] [meta [archive (#+ Archive)]]]]] [luxc @@ -301,13 +301,22 @@ [instanceI (..instance generate archive classD arity env)] (wrap [functionD instanceI])))) -(def: #export (function generate archive [env arity bodyS]) - (Generator Abstraction) - (do phase.monad +(def: #export (function' forced_context generate archive [env arity bodyS]) + (-> (Maybe Context) (Generator Abstraction)) + (do {! phase.monad} [@begin _.make_label - [function_context bodyI] (generation.with_new_context archive - (generation.with_anchor [@begin 1] - (generate archive bodyS))) + [function_context bodyI] (case forced_context + (#.Some function_context) + (do ! + [without_context (generation.with_anchor [@begin 1] + (generate archive bodyS))] + (wrap [function_context + without_context])) + + #.None + (generation.with_new_context archive + (generation.with_anchor [@begin 1] + (generate archive bodyS)))) #let [function_class (//.class_name function_context)] [functionD instanceI] (..with_function generate archive @begin function_class env arity bodyI) #let [directive [function_class @@ -316,9 +325,18 @@ //.$Function (list) functionD)]] _ (generation.execute! directive) - _ (generation.save! (product.right function_context) directive)] + _ (case forced_context + #.None + (generation.save! (product.right function_context) directive) + + (#.Some function_context) + (wrap []))] (wrap instanceI))) +(def: #export function + (Generator Abstraction) + (..function' #.None)) + (def: #export (call generate archive [functionS argsS]) (Generator Apply) (do {@ phase.monad} diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux index baa76ac31..9dc641d7f 100644 --- a/lux-jvm/source/program.lux +++ b/lux-jvm/source/program.lux @@ -21,17 +21,24 @@ ["." file] ["#/." program]] [target - [jvm - [bytecode (#+ Bytecode)]]] + ["." jvm #_ + [bytecode (#+ Bytecode)] + ["#/." type + ["#/." box]]]] [tool [compiler + [reference (#+)] + ["." phase] [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" jvm]]] [language [lux + ["$" synthesis (#+ Synthesis)] + ["." generation] [analysis [macro (#+ Expander)]] [phase @@ -62,6 +69,7 @@ ["." jvm ["." runtime] ["." expression] + ["." function] ["#/." program] ["translation" extension]]]]]) @@ -81,6 +89,11 @@ (java/lang/Class java/lang/Object) (ffi.class_for java/lang/Object)) +(def: _apply1_args + (Array (java/lang/Class java/lang/Object)) + (|> (ffi.array (java/lang/Class java/lang/Object) 1) + (ffi.array_write 0 _object_class))) + (def: _apply2_args (Array (java/lang/Class java/lang/Object)) (|> (ffi.array (java/lang/Class java/lang/Object) 2) @@ -111,6 +124,105 @@ (ffi.array_write 1 (:coerce java/lang/Object lux))) apply_method)))) +(def: how_to_wrap_a_phase + Synthesis + (let [java/lang/String (jvm/type.class "java.lang.String" (list)) + <java/lang/Class> (jvm/type.array (jvm/type.class "java.lang.Class" (list))) + java/lang/Object (jvm/type.class "java.lang.Object" (list)) + <java/lang/Object> (jvm/type.array java/lang/Object) + + jvm_type (: (All [c] (-> (jvm/type.Type c) Synthesis)) + (|>> jvm/type.format + $.text)) + class_type (: (-> Text Synthesis) + (function (_ name) + (|> (jvm/type.class name (list)) + jvm_type))) + unwrap_long (: (-> Synthesis Synthesis) + (|>> (list ($.text jvm/type/box.long) + ($.text "long")) + (#$.Extension "jvm object cast"))) + long_to_int (: (-> Synthesis Synthesis) + (|>> (list) + (#$.Extension "jvm conversion long-to-int"))) + literal_nat (: (-> Nat Synthesis) + (|>> .i64 $.i64 unwrap_long long_to_int)) + array_write (: (-> Text Nat Synthesis Synthesis Synthesis) + (function (_ element_class index value array) + ((#$.Extension "jvm array write object" + (list (jvm_type (jvm/type.array (jvm/type.class element_class (list)))) + (literal_nat index) + value + array))))) + object_array (: (-> Text Nat Synthesis) + (function (_ class_name size) + (#$.Extension "jvm array new object" + (list (class_type class_name) + (literal_nat size))))) + class_of (: (-> Synthesis Synthesis) + (function (_ object) + (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.Object") + ($.text "getClass") + (class_type "java.lang.Class") + object + (list))))) + input (: (All [c] (-> (jvm/type.Type c) Synthesis Synthesis)) + (function (_ value_type value) + ($.tuple (list (jvm_type value_type) value)))) + + example_object (#$.Extension "jvm member invoke constructor" + (list& (class_type "java.lang.Object") + (list))) + phase_arity 3 + $phase ($.variable/local 1) + $archive ($.variable/local 2) + $input ($.variable/local 3) + $state ($.variable/local 4) + apply_method (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.Class") + ($.text "getMethod") + (class_type "java.lang.reflect.Method") + (class_of $phase) + (list (input java/lang/String + ($.text runtime.apply_method)) + (input <java/lang/Class> + (|> (object_array "java.lang.Class" phase_arity) + (array_write "java.lang.Class" 0 (class_of example_object)) + (array_write "java.lang.Class" 1 (class_of example_object)) + (array_write "java.lang.Class" 2 (class_of example_object)))))))] + (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.reflect.Method") + ($.text "invoke") + (class_type "java.lang.Object") + apply_method + (list (input java/lang/Object + $phase) + (input <java/lang/Object> + (|> (object_array "java.lang.Object" phase_arity) + (array_write "java.lang.Object" 0 $archive) + (array_write "java.lang.Object" 1 $input) + (array_write "java.lang.Object" 2 $state)))))))) + +(def: (phase_wrapper archive) + (-> Archive (generation.Operation _.Anchor _.Inst _.Definition platform.Phase_Wrapper)) + (do phase.monad + [instanceG (function.function' (#.Some [0 (.nat -1)]) expression.translate archive [(list) 4 ..how_to_wrap_a_phase]) + phase_wrapper (generation.evaluate! [0 (.nat -2)] instanceG)] + (wrap (function (_ phase) + (<| try.assume + (: (Try java/lang/Object)) + (do try.monad + [apply_method (|> phase_wrapper + (:coerce java/lang/Object) + (java/lang/Object::getClass) + (java/lang/Class::getMethod runtime.apply_method _apply1_args))] + (java/lang/reflect/Method::invoke + (:coerce java/lang/Object phase_wrapper) + (|> (ffi.array java/lang/Object 1) + (ffi.array_write 0 (:coerce java/lang/Object phase))) + apply_method))))))) + (def: #export platform ## (IO (Platform Anchor (Bytecode Any) Definition)) (IO (Platform _.Anchor _.Inst _.Definition)) @@ -123,10 +235,11 @@ #platform.phase expression.translate ## #platform.runtime runtime.generate #platform.runtime runtime.translate + #platform.phase_wrapper ..phase_wrapper #platform.write product.right}))) -(def: extender - Extender +(def: (extender phase_wrapper) + (-> platform.Phase_Wrapper Extender) ## TODO: Stop relying on coercions ASAP. (<| (:coerce Extender) (function (@self handler)) @@ -148,7 +261,7 @@ (:coerce java/lang/Object handler) (|> (ffi.array java/lang/Object 5) (ffi.array_write 0 (:coerce java/lang/Object name)) - (ffi.array_write 1 (:coerce java/lang/Object phase)) + (ffi.array_write 1 (:coerce java/lang/Object (phase_wrapper phase))) (ffi.array_write 2 (:coerce java/lang/Object archive)) (ffi.array_write 3 (:coerce java/lang/Object parameters)) (ffi.array_write 4 (:coerce java/lang/Object state))) @@ -173,7 +286,7 @@ ..platform ## generation.bundle translation.bundle - (directive.bundle ..extender) + (|>> ..extender directive.bundle) (jvm/program.program jvm/runtime.class_name) [_.Anchor _.Inst _.Definition] ..extender |