aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/abstract/interval.lux1
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux178
-rw-r--r--stdlib/source/lux/target/jvm/encoding/unsigned.lux10
-rw-r--r--stdlib/source/lux/target/jvm/type.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux96
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux17
7 files changed, 145 insertions, 166 deletions
diff --git a/stdlib/source/lux/abstract/interval.lux b/stdlib/source/lux/abstract/interval.lux
index f5c3ce656..17e749804 100644
--- a/stdlib/source/lux/abstract/interval.lux
+++ b/stdlib/source/lux/abstract/interval.lux
@@ -1,3 +1,4 @@
+## https://en.wikipedia.org/wiki/Interval_(mathematics)
(.module:
[lux #*]
[//
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
index a31b90195..bba140a7a 100644
--- a/stdlib/source/lux/target/jvm/bytecode.lux
+++ b/stdlib/source/lux/target/jvm/bytecode.lux
@@ -9,8 +9,7 @@
["." state (#+ State')]
["." function]
["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." pipe (#+ when>)]]
+ ["." exception (#+ exception:)]]
[data
["." product]
["." maybe]
@@ -124,13 +123,13 @@
["Expected" (/stack.format expected)]
["Actual" (/stack.format actual)]))
-(with-expansions [<success> (as-is (#try.Success [[pool
- environment
- (update@ #known
- (dictionary.put label [actual (#.Some @here)])
- tracker)]
- [..relative-identity
- []]]))]
+(with-expansions [<success> (as-is (wrap [[pool
+ environment
+ (update@ #known
+ (dictionary.put label [actual (#.Some @here)])
+ tracker)]
+ [..relative-identity
+ []]]))]
(def: #export (set-label label)
(-> Label (Bytecode Any))
(function (_ [pool environment tracker])
@@ -193,7 +192,7 @@
(wrap [[pool
environment'
(set@ #program-counter program-counter' tracker)]
- [(function.constant (#try.Success [..no-exceptions (bytecode input)]))
+ [(function.constant (wrap [..no-exceptions (bytecode input)]))
[]]]))))
(template [<name> <frames>]
@@ -408,11 +407,11 @@
(function (_ [pool environment tracker])
(do try.monad
[_ (/environment.stack environment)]
- (#try.Success [[pool
- (/environment.discontinue environment)
- tracker]
- [..relative-identity
- []]]))))
+ (wrap [[pool
+ (/environment.discontinue environment)
+ tracker]
+ [..relative-identity
+ []]]))))
(template [<name> <consumption> <instruction>]
[(def: #export <name>
@@ -660,6 +659,15 @@
#.None
(exception.throw ..unknown-label [label])))
+(def: (acknowledge-label stack label tracker)
+ (-> Stack Label Tracker Tracker)
+ (case (dictionary.get label (get@ #known tracker))
+ (#.Some _)
+ tracker
+
+ #.None
+ (update@ #known (dictionary.put label [stack #.None]) tracker)))
+
(template [<consumption> <name> <instruction>]
[(def: #export (<name> label)
(-> Label (Bytecode Any))
@@ -675,8 +683,7 @@
[[pool
environment'
(|> tracker
- (when> [(get@ #known) (dictionary.contains? label) not]
- [(update@ #known (dictionary.put label [actual #.None]))])
+ (..acknowledge-label actual label)
(set@ #program-counter program-counter'))]
[(function (_ resolver)
(do try.monad
@@ -689,7 +696,7 @@
(exception.throw ..cannot-do-a-big-jump [label @from jump])
(#.Right jump)
- (#try.Success [..no-exceptions (bytecode jump)]))))
+ (wrap [..no-exceptions (bytecode jump)]))))
[]]])))))))]
[$1 ifeq _.ifeq]
@@ -713,71 +720,49 @@
[$2 if-acmpne _.if-acmpne]
)
-(def: #export (goto label)
- (-> Label (Bytecode Any))
- (let [[estimator bytecode] _.goto]
- (function (_ [pool environment tracker])
- (do try.monad
- [#let [@here (get@ #program-counter tracker)]
- program-counter' (step estimator @here)]
- (wrap (let [@from @here]
- [[pool
- (/environment.discontinue environment)
- (set@ #program-counter program-counter' tracker)]
- [(function (_ resolver)
- (case (dictionary.get label resolver)
- (#.Some [expected (#.Some @to)])
- (do try.monad
- [actual (/environment.stack environment)
- _ (exception.assert ..mismatched-environments [(name-of _.goto) label @here expected actual]
- (:: /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- (#.Left jump)
- (exception.throw ..cannot-do-a-big-jump [label @from jump])
-
- (#.Right jump)
- (#try.Success [..no-exceptions (bytecode jump)])))
-
- (#.Some [expected #.None])
- (exception.throw ..unset-label [label])
-
- #.None
- (exception.throw ..unknown-label [label])))
- []]]))))))
+(template [<name> <instruction> <on-long-jump> <on-short-jump>]
+ [(def: #export (<name> label)
+ (-> Label (Bytecode Any))
+ (let [[estimator bytecode] <instruction>]
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [actual (/environment.stack environment)
+ #let [@here (get@ #program-counter tracker)]
+ program-counter' (step estimator @here)]
+ (wrap (let [@from @here]
+ [[pool
+ (/environment.discontinue environment)
+ (|> tracker
+ (..acknowledge-label actual label)
+ (set@ #program-counter program-counter'))]
+ [(function (_ resolver)
+ (case (dictionary.get label resolver)
+ (#.Some [expected (#.Some @to)])
+ (do try.monad
+ [_ (exception.assert ..mismatched-environments [(name-of <instruction>) label @here expected actual]
+ (:: /stack.equivalence = expected actual))
+ jump (..jump @from @to)]
+ (case jump
+ (#.Left jump)
+ <on-long-jump>
-(def: #export (goto-w label)
- (-> Label (Bytecode Any))
- (let [[estimator bytecode] _.goto-w]
- (function (_ [pool environment tracker])
- (do try.monad
- [#let [@here (get@ #program-counter tracker)]
- program-counter' (step estimator @here)]
- (wrap (let [@from @here]
- [[pool
- (/environment.discontinue environment)
- (set@ #program-counter program-counter' tracker)]
- [(function (_ resolver)
- (case (dictionary.get label resolver)
- (#.Some [expected (#.Some @to)])
- (do try.monad
- [actual (/environment.stack environment)
- _ (exception.assert ..mismatched-environments [(name-of _.goto-w) label @here expected actual]
- (:: /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- (#.Left jump)
- (#try.Success [..no-exceptions (bytecode jump)])
-
- (#.Right jump)
- (#try.Success [..no-exceptions (bytecode (/jump.lift jump))])))
-
- (#.Some [expected #.None])
- (exception.throw ..unset-label [label])
-
- #.None
- (exception.throw ..unknown-label [label])))
- []]]))))))
+ (#.Right jump)
+ <on-short-jump>))
+
+ (#.Some [expected #.None])
+ (exception.throw ..unset-label [label])
+
+ #.None
+ (exception.throw ..unknown-label [label])))
+ []]]))))))]
+
+ [goto _.goto
+ (exception.throw ..cannot-do-a-big-jump [label @from jump])
+ (wrap [..no-exceptions (bytecode jump)])]
+ [goto-w _.goto-w
+ (wrap [..no-exceptions (bytecode jump)])
+ (wrap [..no-exceptions (bytecode (/jump.lift jump))])]
+ )
(def: (big-jump jump)
(-> Any-Jump Big-Jump)
@@ -797,18 +782,20 @@
(do try.monad
[environment' (|> environment
(/environment.consumes $1))
+ actual (/environment.stack environment')
program-counter' (step (estimator (list.size afterwards)) (get@ #program-counter tracker))]
(wrap (let [@from (get@ #program-counter tracker)]
- [[pool environment' (set@ #program-counter program-counter' tracker)]
+ [[pool
+ environment'
+ (|> (list@fold (..acknowledge-label actual) tracker (list& default at-minimum afterwards))
+ (set@ #program-counter program-counter'))]
[(function (_ resolver)
(let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
(function (_ label)
(dictionary.get label resolver)))]
(case (do maybe.monad
- [[_ @default] (get default)
- @default @default
- [_ @at-minimum] (get at-minimum)
- @at-minimum @at-minimum
+ [@default (|> default get (monad.bind @ product.right))
+ @at-minimum (|> at-minimum get (monad.bind @ product.right))
@afterwards (|> afterwards
(monad.map @ get)
(monad.bind @ (monad.map @ product.right)))]
@@ -819,7 +806,7 @@
>at-minimum (:: @ map ..big-jump (..jump @from @at-minimum))
>afterwards (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump))
@afterwards)]
- (#try.Success [..no-exceptions (bytecode minimum >default [>at-minimum >afterwards])]))
+ (wrap [..no-exceptions (bytecode minimum >default [>at-minimum >afterwards])]))
#.None
(exception.throw ..invalid-tableswitch []))))
@@ -838,16 +825,19 @@
(do try.monad
[environment' (|> environment
(/environment.consumes $1))
+ actual (/environment.stack environment')
program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))]
(wrap (let [@from (get@ #program-counter tracker)]
- [[pool environment' (set@ #program-counter program-counter' tracker)]
+ [[pool
+ environment'
+ (|> (list@fold (..acknowledge-label actual) tracker (list& default (list@map product.right cases)))
+ (set@ #program-counter program-counter'))]
[(function (_ resolver)
(let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
(function (_ label)
(dictionary.get label resolver)))]
(case (do maybe.monad
- [[_ @default] (get default)
- @default @default
+ [@default (|> default get (monad.bind @ product.right))
@cases (|> cases
(monad.map @ (|>> product.right get))
(monad.bind @ (monad.map @ product.right)))]
@@ -858,7 +848,7 @@
>cases (|> @cases
(monad.map @ (|>> (..jump @from) (:: @ map ..big-jump)))
(:: @ map (|>> (list.zip2 (list@map product.left cases)))))]
- (#try.Success [..no-exceptions (bytecode >default >cases)]))
+ (wrap [..no-exceptions (bytecode >default >cases)]))
#.None
(exception.throw ..invalid-lookupswitch []))))
@@ -972,9 +962,7 @@
(#try.Success
[[pool
environment
- (|> tracker
- (when> [(get@ #known) (dictionary.contains? @handler) not]
- [(update@ #known (dictionary.put @handler [/stack.catch #.None]))]))]
+ (..acknowledge-label /stack.catch @handler tracker)]
[(function (_ resolver)
(do try.monad
[[_ @start] (..resolve-label @start resolver)
diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
index 4286976dc..65e3632f7 100644
--- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux
+++ b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
@@ -41,16 +41,20 @@
(n.< (:representation reference)
(:representation sample))))
- (exception: #export (value-exceeds-the-maximum {value Nat}
+ (exception: #export (value-exceeds-the-maximum {type Name}
+ {value Nat}
{maximum (Unsigned Any)})
(exception.report
+ ["Type" (%.name type)]
["Value" (%.nat value)]
["Maximum" (%.nat (:representation maximum))]))
(exception: #export [brand] (subtraction-cannot-yield-negative-value
+ {type Name}
{parameter (Unsigned brand)}
{subject (Unsigned brand)})
(exception.report
+ ["Type" (%.name type)]
["Parameter" (%.nat (:representation parameter))]
["Subject" (%.nat (:representation subject))]))
@@ -69,7 +73,7 @@
(-> Nat (Try <name>))
(if (n.<= (:representation <maximum>) value)
(#try.Success (:abstraction value))
- (exception.throw ..value-exceeds-the-maximum [value <maximum>])))
+ (exception.throw ..value-exceeds-the-maximum [(name-of <name>) value <maximum>])))
(def: #export (<+> parameter subject)
(-> <name> <name> (Try <name>))
@@ -83,7 +87,7 @@
subject' (:representation subject)]
(if (n.<= subject' parameter')
(#try.Success (:abstraction (n.- parameter' subject')))
- (exception.throw ..subtraction-cannot-yield-negative-value [parameter subject]))))
+ (exception.throw ..subtraction-cannot-yield-negative-value [(name-of <name>) parameter subject]))))
(def: #export (<max> left right)
(-> <name> <name> <name>)
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index e5c7304ee..1dd5af027 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -5,7 +5,8 @@
[hash (#+ Hash)]]
[data
["." maybe]
- ["." text]
+ ["." text
+ ["%" format (#+ Format)]]
[number
["n" nat]]
[collection
@@ -195,3 +196,7 @@
(text.size repr)))
(:: maybe.monad map (|>> //name.internal //name.external)))
#.None)))
+
+(def: #export format
+ (All [a] (Format (Type a)))
+ (|>> ..signature /signature.signature))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
index 68e81845b..ba9b80add 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
@@ -89,16 +89,12 @@
_.areturn)
_ (do _.monad
[@default _.new-label
- #let [failure ($_ _.compose
- (_.set-label @default)
- ////runtime.apply-failure
- _.aconst-null
- _.areturn)]
@labelsH _.new-label
@labelsT (|> _.new-label
(list.repeat (dec num-partials))
(monad.seq _.monad))
- #let [cases (|> (#.Cons [@labelsH @labelsT])
+ #let [cases (|> (list@compose (#.Cons [@labelsH @labelsT])
+ (list @default))
list.enumerate
(list@map (function (_ [stage @case])
(let [current-partials (|> (list.indices stage)
@@ -107,53 +103,51 @@
already-partial? (n.> 0 stage)
exact-match? (i.= over-extent (.int stage))
has-more-than-necessary? (i.> over-extent (.int stage))]
- (cond exact-match?
- ($_ _.compose
- (_.set-label @case)
- ////reference.this
- (if already-partial?
- (_.invokevirtual class //reset.name (//reset.type class))
- (_@wrap []))
- current-partials
- (..inputs ..this-offset apply-arity)
- (_.invokevirtual class //implementation.name (//implementation.type function-arity))
- _.areturn)
-
- has-more-than-necessary?
- (let [inputs-to-completion (|> function-arity (n.- stage))
- inputs-left (|> apply-arity (n.- inputs-to-completion))]
- ($_ _.compose
- (_.set-label @case)
- ////reference.this
- (_.invokevirtual class //reset.name (//reset.type class))
- current-partials
- (..inputs ..this-offset inputs-to-completion)
- (_.invokevirtual class //implementation.name (//implementation.type function-arity))
- (apply (n.+ ..this-offset inputs-to-completion) inputs-left)
- _.areturn))
+ ($_ _.compose
+ (_.set-label @case)
+ (cond exact-match?
+ ($_ _.compose
+ ////reference.this
+ (if already-partial?
+ (_.invokevirtual class //reset.name (//reset.type class))
+ (_@wrap []))
+ current-partials
+ (..inputs ..this-offset apply-arity)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ _.areturn)
+
+ has-more-than-necessary?
+ (let [inputs-to-completion (|> function-arity (n.- stage))
+ inputs-left (|> apply-arity (n.- inputs-to-completion))]
+ ($_ _.compose
+ ////reference.this
+ (_.invokevirtual class //reset.name (//reset.type class))
+ current-partials
+ (..inputs ..this-offset inputs-to-completion)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ (apply (n.+ ..this-offset inputs-to-completion) inputs-left)
+ _.areturn))
- ## (i.< over-extent (.int stage))
- (let [current-environment (|> (list.indices (list.size environment))
- (list@map (///foreign.get class))
- (monad.seq _.monad))
- missing-partials (|> _.aconst-null
- (list.repeat (|> num-partials (n.- apply-arity) (n.- stage)))
- (monad.seq _.monad))]
- ($_ _.compose
- (_.set-label @case)
- (_.new class)
- _.dup
- current-environment
- ///partial/count.value
- (..increment apply-arity)
- current-partials
- (..inputs ..this-offset apply-arity)
- missing-partials
- (_.invokevirtual class //init.name (//init.type environment function-arity))
- _.areturn))))))
+ ## (i.< over-extent (.int stage))
+ (let [current-environment (|> (list.indices (list.size environment))
+ (list@map (///foreign.get class))
+ (monad.seq _.monad))
+ missing-partials (|> _.aconst-null
+ (list.repeat (|> num-partials (n.- apply-arity) (n.- stage)))
+ (monad.seq _.monad))]
+ ($_ _.compose
+ (_.new class)
+ _.dup
+ current-environment
+ ///partial/count.value
+ (..increment apply-arity)
+ current-partials
+ (..inputs ..this-offset apply-arity)
+ missing-partials
+ (_.invokevirtual class //init.name (//init.type environment function-arity))
+ _.areturn)))))))
(monad.seq _.monad))]]
($_ _.compose
///partial/count.value
(_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT])
- ## cases
- failure)))))))
+ cases)))))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
index 0a51d555d..7308c0734 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
@@ -41,7 +41,7 @@
(def: (partials arity)
(-> Arity (List (Type Value)))
- (list.repeat arity ////type.value))
+ (list.repeat (dec arity) ////type.value))
(def: #export (type environment arity)
(-> Environment Arity (Type category.Method))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
index 89a1b94c1..99a8ed79a 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
@@ -230,12 +230,6 @@
(..illegal-state-exception message)
_.athrow))))
-(def: apply-failure::name "apply_failure")
-(def: #export apply-failure (..procedure ..apply-failure::name ..failure::type))
-
-(def: apply-failure::method
- (..failure ..apply-failure::name "Error while applying function."))
-
(def: pm-failure::name "pm_failure")
(def: #export pm-failure (..procedure ..pm-failure::name ..failure::type))
@@ -515,7 +509,6 @@
(list ..decode-frac::method
..variant::method
- ..apply-failure::method
..pm-failure::method
..push::method
@@ -547,16 +540,10 @@
(_.aload arity)
(_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum))
_.areturn))))))
- (list& (method.method method.public
+ (list& (method.method (modifier@compose method.public method.abstract)
..apply::name (..apply::type //function/arity.minimum)
(list)
- ## TODO: It shouldn't be necessary to set the code for this method, since it's abstract.
- ## Setting this might be a bug. Verify & fix ASAP.
- (#.Some
- ($_ _.compose
- ..apply-failure
- ..this
- _.areturn)))))
+ #.None)))
<init>::method (method.method method.public "<init>" //function.init
(list)
(#.Some