aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source
diff options
context:
space:
mode:
authorEduardo Julian2021-07-08 23:59:00 -0400
committerEduardo Julian2021-07-08 23:59:00 -0400
commitf3e869d0246e956399ec31a074c6c6299ff73602 (patch)
treeba67c7713bbe4ec48232f58a4b324bd364111f95 /lux-jvm/source
parent2b909032e7a0bd10cd7db52067d2fb701bfa95e5 (diff)
Made sure the "phase" parameter of extensions is always usable (even across language boundaries)
Diffstat (limited to '')
-rw-r--r--lux-jvm/source/luxc/lang/directive/jvm.lux40
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux94
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/function.lux34
-rw-r--r--lux-jvm/source/program.lux125
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