aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/function.lux85
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux239
2 files changed, 166 insertions, 158 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
index ae876c3fc..d0764796f 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux
@@ -9,13 +9,13 @@
["." text
format]
[collection
- ["." list ("#/." functor monoid)]]]
+ ["." list ("#@." functor monoid)]]]
[target
- [jvm
- ["." type (#+ Type Method)]]]
+ ["." jvm #_
+ ["#" type (#+ Type Method)]]]
[tool
[compiler
- [analysis (#+ Arity)]
+ [analysis (#+ Arity Environment)]
[synthesis (#+ Synthesis Abstraction Apply)]
["_." reference (#+ Register Variable)]
["." phase
@@ -30,9 +30,8 @@
["." runtime]
["." reference]])
-
(def: arity-field Text "arity")
-(def: $Object Type (type.class "java.lang.Object" (list)))
+(def: $Object Type (jvm.class "java.lang.Object" (list)))
(def: (poly-arg? arity)
(-> Arity Bit)
@@ -40,29 +39,29 @@
(def: (reset-method class)
(-> Text Method)
- (type.method (list) (#.Some (type.class class (list))) (list)))
+ (jvm.method (list) (#.Some (jvm.class class (list))) (list)))
(def: (captured-args env)
- (-> (List Variable) (List Type))
+ (-> Environment (List Type))
(list.repeat (list.size env) $Object))
(def: (init-method env arity)
- (-> (List Variable) Arity Method)
+ (-> Environment Arity Method)
(if (poly-arg? arity)
- (type.method (list.concat (list (captured-args env)
- (list type.int)
- (list.repeat (dec arity) $Object)))
- #.None
- (list))
- (type.method (captured-args env) #.None (list))))
+ (jvm.method (list.concat (list (captured-args env)
+ (list jvm.int)
+ (list.repeat (dec arity) $Object)))
+ #.None
+ (list))
+ (jvm.method (captured-args env) #.None (list))))
(def: (implementation-method arity)
- (type.method (list.repeat arity $Object) (#.Some $Object) (list)))
+ (jvm.method (list.repeat arity $Object) (#.Some $Object) (list)))
(def: get-amount-of-partialsI
Inst
(|>> (_.ALOAD 0)
- (_.GETFIELD //.function-class runtime.partials-field type.int)))
+ (_.GETFIELD //.function-class runtime.partials-field jvm.int)))
(def: (load-fieldI class field)
(-> Text Text Inst)
@@ -72,7 +71,7 @@
(def: (inputsI start amount)
(-> Register Nat Inst)
(|> (list.n/range start (n/+ start (dec amount)))
- (list/map _.ALOAD)
+ (list@map _.ALOAD)
_.fuse))
(def: (applysI start amount)
@@ -97,24 +96,24 @@
(list.repeat amount)
_.fuse))
-(def: (with-captured env)
- (-> (List Variable) Def)
- (|> (list.enumerate env)
- (list/map (.function (_ [env-idx env-source])
- (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object)))
- def.fuse))
+(def: #export with-environment
+ (-> Environment Def)
+ (|>> list.enumerate
+ (list@map (.function (_ [env-idx env-source])
+ (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object)))
+ def.fuse))
(def: (with-partial arity)
(-> Arity Def)
(if (poly-arg? arity)
(|> (list.n/range 0 (n/- 2 arity))
- (list/map (.function (_ idx)
+ (list@map (.function (_ idx)
(def.field #$.Private $.finalF (reference.partial-name idx) $Object)))
def.fuse)
function.identity))
(def: (instance class arity env)
- (-> Text Arity (List Variable) (Operation Inst))
+ (-> Text Arity Environment (Operation Inst))
(do phase.monad
[captureI+ (monad.map @ reference.variable env)
#let [argsI (if (poly-arg? arity)
@@ -129,14 +128,14 @@
(_.INVOKESPECIAL class "<init>" (init-method env arity) #0)))))
(def: (with-reset class arity env)
- (-> Text Arity (List Variable) Def)
+ (-> Text Arity Environment Def)
(def.method #$.Public $.noneM "reset" (reset-method class)
(if (poly-arg? arity)
(let [env-size (list.size env)
captureI (|> (case env-size
0 (list)
_ (list.n/range 0 (dec env-size)))
- (list/map (.function (_ source)
+ (list@map (.function (_ source)
(|>> (_.ALOAD 0)
(_.GETFIELD class (reference.foreign-name source) $Object))))
_.fuse)
@@ -161,7 +160,7 @@
(def: function-init-method
Method
- (type.method (list type.int) #.None (list)))
+ (jvm.method (list jvm.int) #.None (list)))
(def: (function-init arity env-size)
(-> Arity Nat Inst)
@@ -172,21 +171,21 @@
(_.INVOKESPECIAL //.function-class "<init>" function-init-method #0))))
(def: (with-init class env arity)
- (-> Text (List Variable) Arity Def)
+ (-> Text Environment Arity Def)
(let [env-size (list.size env)
offset-partial (: (-> Nat Nat)
(|>> inc (n/+ env-size)))
store-capturedI (|> (case env-size
0 (list)
_ (list.n/range 0 (dec env-size)))
- (list/map (.function (_ register)
+ (list@map (.function (_ register)
(|>> (_.ALOAD 0)
(_.ALOAD (inc register))
(_.PUTFIELD class (reference.foreign-name register) $Object))))
_.fuse)
store-partialI (if (poly-arg? arity)
(|> (list.n/range 0 (n/- 2 arity))
- (list/map (.function (_ idx)
+ (list@map (.function (_ idx)
(let [register (offset-partial idx)]
(|>> (_.ALOAD 0)
(_.ALOAD (inc register))
@@ -201,18 +200,18 @@
_.RETURN))))
(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List Variable) Arity Label Inst Arity
+ (-> Text Environment Arity Label Inst Arity
Def)
(let [num-partials (dec function-arity)
@default ($.new-label [])
- @labels (list/map $.new-label (list.repeat num-partials []))
+ @labels (list@map $.new-label (list.repeat num-partials []))
arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity)))
- casesI (|> (list/compose @labels (list @default))
+ casesI (|> (list@compose @labels (list @default))
(list.zip2 (list.n/range 0 num-partials))
- (list/map (.function (_ [stage @label])
+ (list@map (.function (_ [stage @label])
(let [load-partialsI (if (n/> 0 stage)
(|> (list.n/range 0 (dec stage))
- (list/map (|>> reference.partial-name (load-fieldI class)))
+ (list@map (|>> reference.partial-name (load-fieldI class)))
_.fuse)
function.identity)]
(cond (i/= arity-over-extent (.int stage))
@@ -242,7 +241,7 @@
load-capturedI (|> (case env-size
0 (list)
_ (list.n/range 0 (dec env-size)))
- (list/map (|>> reference.foreign-name (load-fieldI class)))
+ (list@map (|>> reference.foreign-name (load-fieldI class)))
_.fuse)]
(|>> (_.label @label)
(_.NEW class)
@@ -262,20 +261,20 @@
(_.TABLESWITCH +0 (|> num-partials dec .int)
@default @labels)
casesI
- (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0)
+ (_.INVOKESTATIC //.runtime-class "apply_fail" (jvm.method (list) #.None (list)) #0)
_.NULL
_.ARETURN
))))
(def: #export (with-function @begin class env arity bodyI)
- (-> Label Text (List Variable) Arity Inst
+ (-> Label Text Environment Arity Inst
(Operation [Def Inst]))
(let [env-size (list.size env)
applyD (: Def
(if (poly-arg? arity)
(|> (n/min arity runtime.num-apply-variants)
(list.n/range 1)
- (list/map (with-apply class env arity @begin bodyI))
+ (list@map (with-apply class env arity @begin bodyI))
(list& (with-implementation arity @begin bodyI))
def.fuse)
(def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1)
@@ -284,7 +283,7 @@
_.ARETURN))))
functionD (: Def
(|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity))
- (with-captured env)
+ (with-environment env)
(with-partial arity)
(with-init class env arity)
(with-reset class arity env)
@@ -323,7 +322,7 @@
[functionI (translate functionS)
argsI (monad.map @ translate argsS)
#let [applyI (|> (segment runtime.num-apply-variants argsI)
- (list/map (.function (_ chunkI+)
+ (list@map (.function (_ chunkI+)
(|>> (_.CHECKCAST //.function-class)
(_.fuse chunkI+)
(_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index 55798c806..be2a0bace 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -31,6 +31,8 @@
["." generation
[extension (#+ Nullary Unary Binary
nullary unary binary)]]
+ [analysis
+ [".A" reference]]
["." extension
["." bundle]
[analysis
@@ -39,17 +41,27 @@
[luxc
[lang
[host
- ["$" jvm (#+ Label Inst Handler Bundle Operation Phase)
+ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
["_" inst]
- ["_." def]]]]])
+ ["_." def]]]]]
+ ["." /// #_
+ ["#." reference]
+ ["#." function]])
-(template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
+(exception: #export invalid-syntax-for-argument-generation)
- [invalid-syntax-for-jvm-type]
- [invalid-syntax-for-argument-generation]
- )
+(def: (custom [parser handler])
+ (All [s]
+ (-> [(<s>.Parser s)
+ (-> Text Phase s (Operation Inst))]
+ Handler))
+ (function (_ extension-name phase input)
+ (case (<s>.run input parser)
+ (#error.Success input')
+ (handler extension-name phase input')
+
+ (#error.Failure error)
+ (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
(template [<name> <inst>]
[(def: <name>
@@ -306,7 +318,17 @@
"char" jvm.char
_ (jvm.class elem-class (list)))))
-(def: (array::length extension-name generate inputs)
+(def: (primitive-array-length-handler jvm-primitive)
+ (-> Type Handler)
+ (..custom [<s>.any
+ (function (_ extension-name generate arrayS)
+ (do phase.monad
+ [arrayI (generate arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
+ _.ARRAYLENGTH))))]))
+
+(def: (array::length::object extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.i64 nesting)
@@ -427,7 +449,17 @@
Bundle
(<| (bundle.prefix "array")
(|> bundle.empty
- (bundle.install "length" array::length)
+ (dictionary.merge (<| (bundle.prefix "length")
+ (|> bundle.empty
+ (bundle.install "boolean" (primitive-array-length-handler jvm.boolean))
+ (bundle.install "byte" (primitive-array-length-handler jvm.byte))
+ (bundle.install "short" (primitive-array-length-handler jvm.short))
+ (bundle.install "int" (primitive-array-length-handler jvm.int))
+ (bundle.install "long" (primitive-array-length-handler jvm.long))
+ (bundle.install "float" (primitive-array-length-handler jvm.float))
+ (bundle.install "double" (primitive-array-length-handler jvm.double))
+ (bundle.install "char" (primitive-array-length-handler jvm.char))
+ (bundle.install "object" array::length::object))))
(dictionary.merge (<| (bundle.prefix "new")
(|> bundle.empty
(bundle.install "boolean" (new-primitive-array-handler jvm.boolean))
@@ -671,62 +703,30 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: base-type
- (<t>.Parser Type)
- ($_ <>.either
- (<>.after (<t>.this "boolean") (<>@wrap jvm.boolean))
- (<>.after (<t>.this "byte") (<>@wrap jvm.byte))
- (<>.after (<t>.this "short") (<>@wrap jvm.short))
- (<>.after (<t>.this "int") (<>@wrap jvm.int))
- (<>.after (<t>.this "long") (<>@wrap jvm.long))
- (<>.after (<t>.this "float") (<>@wrap jvm.float))
- (<>.after (<t>.this "double") (<>@wrap jvm.double))
- (<>.after (<t>.this "char") (<>@wrap jvm.char))
- (<>@map (function (_ name)
- (jvm.class name (list)))
- (<t>.many (<t>.none-of "[")))
- ))
-
-(def: java-type
- (<t>.Parser Type)
- (do <>.monad
- [raw base-type
- nesting (<>.some (<t>.this "[]"))]
- (wrap (jvm.array (list.size nesting) raw))))
-
-(def: (generate-type argD)
- (-> Text (Operation Type))
- (case (<t>.run java-type argD)
- (#error.Failure error)
- (phase.throw invalid-syntax-for-jvm-type argD)
-
- (#error.Success type)
- (phase@wrap type)))
-
(def: (generate-arg generate argS)
(-> (-> Synthesis (Operation Inst)) Synthesis
(Operation [Type Inst]))
(case argS
(^ (synthesis.tuple (list (synthesis.text argD) argS)))
(do phase.monad
- [argD (phase.lift (:: error.monad map
- jvm.reflection-class
- (jvm.parse-signature argD)))
- argT (generate-type argD)
+ [argT (phase.lift (<t>.run jvm.parse-signature argD))
argI (generate argS)]
(wrap [argT argI]))
_
- (phase.throw invalid-syntax-for-argument-generation "")))
+ (phase.throw invalid-syntax-for-argument-generation [])))
(def: (method-return-type description)
(-> Text (Operation (Maybe Type)))
(case description
- "void"
+ (^ (static jvm.void-descriptor))
(phase@wrap #.None)
_
- (phase@map (|>> #.Some) (generate-type description))))
+ (|> description
+ (<t>.run jvm.parse-signature)
+ phase.lift
+ (phase@map (|>> #.Some)))))
(def: (prepare-argI [type argI])
(-> [Type Inst] Inst)
@@ -738,46 +738,35 @@
#.None
argI))
-(def: (invoke::static extension-name generate inputs)
+(def: invoke::static
Handler
- (case inputs
- (^ (list& (synthesis.text class)
- (synthesis.text method)
- (synthesis.text unboxed)
- argsS))
- (do phase.monad
- [argsTI (monad.map @ (generate-arg generate) argsS)
- returnT (method-return-type unboxed)]
- (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
- (_.INVOKESTATIC class method
- (jvm.method (list@map product.left argsTI) returnT (list))
- false))))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any))
+ (function (_ extension-name generate [class method unboxed argsS])
+ (do phase.monad
+ [argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
+ (_.INVOKESTATIC class method
+ (jvm.method (list@map product.left argsTI) returnT (list))
+ false)))))]))
(template [<name> <invoke> <interface?>]
- [(def: (<name> extension-name generate inputs)
+ [(def: <name>
Handler
- (case inputs
- (^ (list& (synthesis.text class)
- (synthesis.text method)
- (synthesis.text unboxed)
- objectS
- argsS))
- (do phase.monad
- [objectI (generate objectS)
- argsTI (monad.map @ (generate-arg generate) argsS)
- returnT (method-return-type unboxed)]
- (wrap (|>> objectI
- (_.CHECKCAST class)
- (_.fuse (list@map ..prepare-argI argsTI))
- (<invoke> class method
- (jvm.method (list@map product.left argsTI) returnT (list))
- <interface?>))))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))]
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension-name generate [class method unboxed objectS argsS])
+ (do phase.monad
+ [objectI (generate objectS)
+ argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.fuse (list@map ..prepare-argI argsTI))
+ (<invoke> class method
+ (jvm.method (list@map product.left argsTI) returnT (list))
+ <interface?>)))))]))]
[invoke::virtual _.INVOKEVIRTUAL false]
[invoke::special _.INVOKESPECIAL false]
@@ -821,19 +810,6 @@
(bundle.install "constructor" invoke::constructor))))
)))
-(def: (custom [parser handler])
- (All [s]
- (-> [(<s>.Parser s)
- (-> Text Phase s (Operation Inst))]
- Handler))
- (function (_ extension-name phase input)
- (case (<s>.run input parser)
- (#error.Success input')
- (handler extension-name phase input')
-
- (#error.Failure error)
- (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
-
(def: var
(<s>.Parser Var)
<s>.text)
@@ -902,7 +878,7 @@
(def: return
(<s>.Parser Return)
- (<>.or (<s>.constant! ["" "void"])
+ (<>.or (<s>.constant! ["" jvm.void-descriptor])
..jvm-type))
(def: overriden-method-definition
@@ -998,6 +974,39 @@
(#synthesis.Extension [name inputsS+])
(#synthesis.Extension [name (list@map recur inputsS+)]))))
+(def: $Object (jvm.class jvm.object-class (list)))
+
+(def: (anonymous-init-method env)
+ (-> Environment Method)
+ (jvm.method (list.repeat (list.size env) $Object)
+ #.None
+ (list)))
+
+(def: (with-anonymous-init class env)
+ (-> Text Environment Def)
+ (let [store-capturedI (|> env
+ list.size
+ list.indices
+ (list@map (.function (_ register)
+ (|>> (_.ALOAD 0)
+ (_.ALOAD (inc register))
+ (_.PUTFIELD class (///reference.foreign-name register) $Object))))
+ _.fuse)]
+ (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env)
+ (|>> (_.ALOAD 0)
+ (_.INVOKESPECIAL jvm.object-class "<init>" (jvm.method (list) #.None (list)) #0)
+ store-capturedI
+ _.RETURN))))
+
+(def: (anonymous-instance class env)
+ (-> Text Environment (Operation Inst))
+ (do phase.monad
+ [captureI+ (monad.map @ ///reference.variable env)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse captureI+)
+ (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0)))))
+
(def: class::anonymous
Handler
(..custom
@@ -1012,14 +1021,15 @@
constructor-args
overriden-methods])
(do phase.monad
- [#let [global-mapping (|> overriden-methods
- ## Get all the environments.
- (list@map product.left)
- ## Combine them.
- list@join
- ## Remove duplicates.
- (set.from-list reference.hash)
- set.to-list
+ [#let [total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list@map product.left)
+ ## Combine them.
+ list@join
+ ## Remove duplicates.
+ (set.from-list reference.hash)
+ set.to-list)
+ global-mapping (|> total-environment
## Give them names as "foreign" variables.
list.enumerate
(list@map (function (_ [id capture])
@@ -1043,14 +1053,13 @@
self-name arguments returnT exceptionsT
(normalize-method-body local-mapping body)]))
overriden-methods)]
- ## _ (generation.save! true ["" function-class]
- ## [function-class
- ## (def.class #$.V1_6 #$.Public $.finalC
- ## function-class (list)
- ## ($.simple-class //.function-class) (list)
- ## functionD)])
- _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])]
- (wrap _.DUP)))]))
+ _ (generation.save! true ["" class-name]
+ [class-name
+ (_def.class #$.V1_6 #$.Public $.finalC
+ class-name (list)
+ super-class super-interfaces
+ (|>> (///function.with-environment total-environment)))])]
+ (anonymous-instance class-name total-environment)))]))
(def: bundle::class
Bundle