From f3e869d0246e956399ec31a074c6c6299ff73602 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 8 Jul 2021 23:59:00 -0400 Subject: Made sure the "phase" parameter of extensions is always usable (even across language boundaries) --- lux-jvm/source/luxc/lang/directive/jvm.lux | 40 ++++++--- .../luxc/lang/translation/jvm/extension/host.lux | 94 +++++++++++----------- .../source/luxc/lang/translation/jvm/function.lux | 34 ++++++-- 3 files changed, 104 insertions(+), 64 deletions(-) (limited to 'lux-jvm/source/luxc/lang') 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 [] [( 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 [ (as_is jvm.Anchor) + (as_is Inst) + (as_is jvm.Definition) + (as_is )] + (type: Handler + ## (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) + (-> extension.Name + (phase.Phase [(extension.Bundle ) + (generation.State )] + Synthesis + ) + (phase.Phase [(extension.Bundle ) + (generation.State )] + (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) - ["" text] - ["" synthesis (#+ Parser)]]] + ["<.>" text] + ["<.>" synthesis (#+ Parser)]]] [data ["." product] ["." maybe ("#@." functor)] @@ -66,7 +66,7 @@ (template [ ] [(def: #export (Parser (Type )) - (.embed .text))] + (.embed .text))] [var Var parser.var] [class Class parser.class] @@ -82,7 +82,7 @@ (def: #export object_array (Parser (Type Object)) (do <>.monad - [arrayJT (.embed parser.array .text)] + [arrayJT (.embed parser.array .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 - [.any + [.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 .any) + [($_ <>.and ..object_array .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 .any) + [($_ <>.and ..object .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 .any .any) + [($_ <>.and ..object_array .any .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 .any .any .any) + [($_ <>.and ..object_array .any .any .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 .text .any) + [($_ <>.and .text .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 .text .text .text) + [($_ <>.and .text .text .text) (function (_ extension_name generate archive [class field unboxed]) (do phase.monad [] @@ -625,7 +626,7 @@ (def: put::static Handler (..custom - [($_ <>.and .text .text .text .any) + [($_ <>.and .text .text .text .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 .text .text .text .any) + [($_ <>.and .text .text .text .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 .text .text .text .any .any) + [($_ <>.and .text .text .text .any .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) - (.tuple (<>.and ..value .any))) + (.tuple (<>.and ..value .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 .text ..return (<>.some ..input)) + [($_ <>.and ..class .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: Handler (..custom - [($_ <>.and ..class .text ..return .any (<>.some ..input)) + [($_ <>.and ..class .text ..return .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)) - (.tuple (<>.and .text .any))) + (.tuple (<>.and .text .any))) (def: annotation (Parser (/.Annotation Synthesis)) - (.tuple (<>.and .text (<>.some ..annotation_parameter)))) + (.tuple (<>.and .text (<>.some ..annotation_parameter)))) (def: argument (Parser Argument) - (.tuple (<>.and .text ..value))) + (.tuple (<>.and .text ..value))) (def: overriden_method_definition (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) - (.tuple (do <>.monad - [_ (.text! /.overriden_tag) - ownerT ..class - name .text - strict_fp? .bit - annotations (.tuple (<>.some ..annotation)) - vars (.tuple (<>.some ..var)) - self_name .text - arguments (.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (.tuple (<>.some ..class)) - [environment _ _ body] (.function 1 - (.loop (<>.exactly 0 .any) - (.tuple .any)))] - (wrap [environment - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - body]])))) + (.tuple + (do <>.monad + [_ (.text! /.overriden_tag) + ownerT ..class + name .text + strict_fp? .bit + annotations (.tuple (<>.some ..annotation)) + vars (.tuple (<>.some ..var)) + self_name .text + arguments (.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (.tuple (<>.some ..class)) + [environment _ _ body] (.function 1 + (.loop (<>.exactly 0 .any) + (.tuple .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 - (.tuple (<>.some ..class)) - (.tuple (<>.some ..input)) - (.tuple (<>.some ..overriden_method_definition))) + (.tuple (<>.some ..class)) + (.tuple (<>.some ..input)) + (.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} -- cgit v1.2.3