aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2018-04-15 02:24:27 -0400
committerEduardo Julian2018-04-15 02:24:27 -0400
commit6eb9cf17f161522d4eddf6783284952f8a84f099 (patch)
tree9158749544826d8d0940117ca5884fdd2f90c327 /new-luxc/source
parent0bba53ceb52502510e0f6ba4c53a951933532a61 (diff)
- Fixes for R back-end.
Diffstat (limited to 'new-luxc/source')
-rw-r--r--new-luxc/source/luxc/lang/host/r.lux27
-rw-r--r--new-luxc/source/luxc/lang/translation/r/case.jvm.lux29
-rw-r--r--new-luxc/source/luxc/lang/translation/r/eval.jvm.lux13
-rw-r--r--new-luxc/source/luxc/lang/translation/r/function.jvm.lux9
-rw-r--r--new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux16
-rw-r--r--new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux146
6 files changed, 154 insertions, 86 deletions
diff --git a/new-luxc/source/luxc/lang/host/r.lux b/new-luxc/source/luxc/lang/host/r.lux
index 5394b756f..6af15d058 100644
--- a/new-luxc/source/luxc/lang/host/r.lux
+++ b/new-luxc/source/luxc/lang/host/r.lux
@@ -44,10 +44,15 @@
(|>> (format "\n")
(text.replace-all "\n" "\n ")))
- (def: (block expression)
+ (def: (_block expression)
(-> Text Text)
(format "{" (nest expression) "\n" "}"))
+ (def: #export (block expression)
+ (-> Expression Expression)
+ (@abstraction
+ (format "{" (@representation expression) "}")))
+
(def: #export null
Expression
(|> "NULL" self-contained))
@@ -135,7 +140,7 @@
(self-contained
(format (@representation func)
(format "("
- (text.join-with "," (list/map expression args))
+ (text.join-with "," (list/map expression args)) ","
(text.join-with "," (list/map (.function (_ [key val])
(format key "=" (expression val)))
kw-args))
@@ -150,14 +155,14 @@
(-> Expression Expression Expression Expression)
(self-contained
(format "if(" (@representation test) ")"
- " " (block (@representation then))
- " else " (block (@representation else)))))
+ " " (.._block (@representation then))
+ " else " (.._block (@representation else)))))
(def: #export (when test then)
(-> Expression Expression Expression)
(self-contained
(format "if(" (@representation test) ") {"
- (block (@representation then))
+ (.._block (@representation then))
"\n" "}")))
(def: #export (cond clauses else)
@@ -237,7 +242,7 @@
(let [args (|> inputs (list/map ..name) (text.join-with ", "))]
(self-contained
(format "function(" args ") "
- (..block (@representation body))))))
+ (.._block (@representation body))))))
(def: #export (try body warning error finally)
(-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression)
@@ -248,23 +253,23 @@
(maybe.default ""))))]
(self-contained
(format "tryCatch("
- (..block (@representation body))
+ (.._block (@representation body))
(optional "warning" warning id)
(optional "error" error id)
- (optional "finally" finally ..block)
+ (optional "finally" finally .._block)
")"))))
(def: #export (while test body)
(-> Expression Expression Expression)
(self-contained
(format "while (" (@representation test) ") "
- (..block (@representation body)))))
+ (.._block (@representation body)))))
(def: #export (for-in var inputs body)
(-> SVar Expression Expression Expression)
(self-contained
(format "for (" (..name var) " in " (..expression inputs) ")"
- (..block (@representation body)))))
+ (.._block (@representation body)))))
(do-template [<name> <keyword>]
[(def: #export (<name> message)
@@ -283,7 +288,7 @@
(def: #export (set-nth! idx value list)
(-> Expression Expression SVar Expression)
(self-contained
- (format (..name list) "[" (@representation idx) "] <- " (@representation value))))
+ (format (..name list) "[[" (@representation idx) "]] <- " (@representation value))))
(def: #export (then pre post)
(-> Expression Expression Expression)
diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
index 67de862e8..6ceae3842 100644
--- a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
@@ -25,9 +25,10 @@
[valueO (translate valueS)
bodyO (translate bodyS)
#let [$register (referenceT.variable register)]]
- (wrap ($_ r.then
- (r.set! $register valueO)
- bodyO))))
+ (wrap (r.block
+ ($_ r.then
+ (r.set! $register valueO)
+ bodyO)))))
(def: #export (translate-record-get translate valueS pathP)
(-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bool])
@@ -73,7 +74,7 @@
(def: cursor-top
Expression
- (top (@@ $cursor)))
+ (|> (@@ $cursor) (r.nth (top (@@ $cursor)))))
(def: pop-cursor!
Expression
@@ -115,13 +116,18 @@
[_ (<tag> value)]
(meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top))
fail-pm!)))
- ([#.Nat (<| runtimeT.int (:! Int))]
- [#.Int runtimeT.int]
- [#.Deg (<| runtimeT.int (:! Int))]
- [#.Bool r.bool]
+ ([#.Bool r.bool]
[#.Frac r.float]
[#.Text r.string])
+ (^template [<tag> <format>]
+ [_ (<tag> value)]
+ (meta/wrap (r.when (r.not (runtimeT.int//= (|> value <format>) cursor-top))
+ fail-pm!)))
+ ([#.Nat (<| runtimeT.int (:! Int))]
+ [#.Int runtimeT.int]
+ [#.Deg (<| runtimeT.int (:! Int))])
+
(^template [<pm> <getter>]
(^code (<pm> (~ [_ (#.Nat idx)])))
(meta/wrap (push-cursor! (<getter> cursor-top (r.int (:! Int idx))))))
@@ -183,6 +189,7 @@
(do macro.Monad<Meta>
[valueO (translate valueS)
pattern-matching! (translate-pattern-matching translate pathP)]
- (wrap ($_ r.then
- (initialize-pattern-matching! valueO)
- pattern-matching!))))
+ (wrap (r.block
+ ($_ r.then
+ (initialize-pattern-matching! valueO)
+ pattern-matching!)))))
diff --git a/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
index c026750a7..5685ae05e 100644
--- a/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/eval.jvm.lux
@@ -81,7 +81,7 @@
(Long::intValue []))
(: Top
(if (host.instance? Null flag)
- host.null
+ (host.null)
//.unit))
value])))
@@ -90,9 +90,14 @@
(do e.Monad<Error>
[high (ListVector::get-field-sexp [//.int-high-field] host-object)
low (ListVector::get-field-sexp [//.int-low-field] host-object)
- #let [high (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector high)))
- low (:! Nat (IntArrayVector::getElementAsInt [0] (:! IntArrayVector low)))]]
- (wrap (|> high (bit.shift-left +32) (n/+ low) nat-to-int))))
+ #let [get-int-32 (|>> (IntArrayVector::getElementAsInt [0]) (:! Nat))
+ high (get-int-32 (:! IntArrayVector high))
+ low (get-int-32 (:! IntArrayVector low))]]
+ (wrap (:! Int
+ (n/+ (|> high (bit.shift-left +32))
+ (if (i/< 0 (:! Int low))
+ (|> low (bit.shift-left +32) (bit.shift-right +32))
+ low))))))
(def: (lux-object host-object)
(-> Object (Error Top))
diff --git a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
index 3d4407bd0..565a44909 100644
--- a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
@@ -60,13 +60,14 @@
#let [arityO (|> arity nat-to-int r.int)
$num_args (r.var "num_args")
$function (r.var function-name)
+ var-args (r.code (format "list" (r.expression (@@ r.var-args))))
apply-poly (function (_ args func)
(r.apply (list func args) (r.global "do.call")))]]
(with-closure function-name closureO+
(r.set! $function
(r.function (list r.var-args)
($_ r.then
- (r.set! $curried (@@ r.var-args))
+ (r.set! $curried var-args)
(r.set! $num_args (r.length (@@ $curried)))
(r.cond (list [(|> (@@ $num_args) (r.= arityO))
($_ r.then
@@ -76,7 +77,9 @@
(list/fold r.then bodyO)))]
[(|> (@@ $num_args) (r.> arityO))
(let [arity-args (r.slice (r.int 1) arityO (@@ $curried))
- output-func-args (r.slice arityO (@@ $num_args) (@@ $curried))]
+ output-func-args (r.slice (|> arityO (r.+ (r.int 1)))
+ (@@ $num_args)
+ (@@ $curried))]
(|> (@@ $function)
(apply-poly arity-args)
(apply-poly output-func-args)))])
@@ -84,7 +87,7 @@
(let [$missing (r.var "missing")]
(r.function (list r.var-args)
($_ r.then
- (r.set! $missing (@@ r.var-args))
+ (r.set! $missing var-args)
(|> (@@ $function)
(apply-poly (r.apply (list (@@ $curried) (@@ $missing))
(r.global "append"))))))))))))
diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
index 1bcd560e9..bc2289f6a 100644
--- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
@@ -165,7 +165,7 @@
(do-template [<name> <op>]
[(def: (<name> [subjectO paramO])
Binary
- (<op> paramO subjectO))]
+ (<op> (runtimeT.int64-low paramO) subjectO))]
[bit//shift-left runtimeT.bit//shift-left]
[bit//signed-shift-right runtimeT.bit//signed-shift-right]
@@ -312,6 +312,8 @@
(function (_ value)
(r.apply (list value) func)))
+(def: nat//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8"))))
+
(def: nat-procs
Bundle
(<| (prefix "nat")
@@ -326,7 +328,7 @@
(install "min" (nullary nat//min))
(install "max" (nullary nat//max))
(install "to-int" (unary id))
- (install "char" (unary (apply1 (r.global "intToUtf8")))))))
+ (install "char" (unary nat//char)))))
(def: int-procs
Bundle
@@ -459,17 +461,21 @@
## [[IO]]
(def: (io//exit input)
- (-> Expression Expression)
+ Unary
(r.apply-kw (list)
(list ["status" (runtimeT.int//to-float input)])
(r.global "quit")))
+(def: (void code)
+ (-> Expression Expression)
+ (r.block (r.then code runtimeT.unit)))
+
(def: io-procs
Bundle
(<| (prefix "io")
(|> (dict.new text.Hash<Text>)
- (install "log" (unary (apply1 (r.global "print"))))
- (install "error" (unary (apply1 (r.global "stop"))))
+ (install "log" (unary (|>> r.print ..void)))
+ (install "error" (unary r.stop))
(install "exit" (unary io//exit))
(install "current-time" (nullary (function (_ _)
(runtimeT.io//current-time! runtimeT.unit)))))))
diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
index b75da1804..30eaf2a77 100644
--- a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
@@ -18,13 +18,31 @@
(def: #export unit Expression (r.string //.unit))
-(def: high (|>> int-to-nat (bit.shift-right +32) nat-to-int))
-(def: low (|>> int-to-nat (bit.and (hex "+FFFFFFFF")) nat-to-int))
+(def: full-32 (hex "+FFFFFFFF"))
+(def: half-32 (hex "+7FFFFFFF"))
+(def: post-32 (hex "+100000000"))
+
+(def: (cap-32 input)
+ (-> Nat Int)
+ (cond (n/> full-32 input)
+ (|> input (bit.and full-32) cap-32)
+
+ (n/> half-32 input)
+ (|> post-32 (n/- input) nat-to-int (i/* -1))
+
+ ## else
+ (nat-to-int input)))
+
+(def: high-32 (bit.shift-right +32))
+(def: low-32 (|>> (bit.and (hex "+FFFFFFFF"))))
(def: #export (int value)
(-> Int Expression)
- (r.named-list (list [//.int-high-field (r.int (high value))]
- [//.int-low-field (r.int (low value))])))
+ (let [value (int-to-nat value)
+ high (|> value ..high-32 cap-32)
+ low (|> value ..low-32 cap-32)]
+ (r.named-list (list [//.int-high-field (r.int high)]
+ [//.int-low-field (r.int low)]))))
(def: (flag value)
(-> Bool Expression)
@@ -74,7 +92,7 @@
$runtime (` (r.var (~ (code.text runtime))))
@runtime (` (@@ (~ $runtime)))
argsC+ (list/map code.local-symbol args)
- argsLC+ (list/map (|>> lang.normalize-name code.text (~) (r.var) (`))
+ argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`))
args)
declaration (` ((~ (code.local-symbol name))
(~+ argsC+)))
@@ -82,7 +100,12 @@
r.Expression))]
(wrap (list (` (def: (~' #export) (~ declaration)
(~ type)
- (r.apply (list (~+ argsC+)) (~ @runtime))))
+ (~ (case argsC+
+ #.Nil
+ @runtime
+
+ _
+ (` (r.apply (list (~+ argsC+)) (~ @runtime)))))))
(` (def: (~ implementation)
r.Expression
(~ (case argsC+
@@ -109,8 +132,12 @@
(def: high-shift (r.bit-shl (r.int 32)))
-(def: f2^32 (|> (r.int 1) high-shift))
-(def: f2^63 (|> (r.int 1) (r.bit-shl (r.int 63))))
+(runtime: f2^32 (|> (r.int 2) (r.** (r.int 32))))
+(runtime: f2^63 (|> (r.int 2) (r.** (r.int 63))))
+
+(def: (as-double value)
+ (-> Expression Expression)
+ (r.apply (list value) (r.global "as.double")))
(def: (as-integer value)
(-> Expression Expression)
@@ -130,24 +157,24 @@
high-shift)
low (|> (@@ input)
int//unsigned-low)]
- (|> high (r.+ low))))
+ (|> high (r.+ low) as-double)))
(runtime: (int//new high low)
(r.named-list (list [//.int-high-field (as-integer (@@ high))]
[//.int-low-field (as-integer (@@ low))])))
-(do-template [<name> <high> <low>]
+(do-template [<name> <value>]
[(runtime: <name>
- (int//new (r.int <high>) (r.int <low>)))]
+ (..int <value>))]
- [int//zero 0 0]
- [int//one 0 1]
- [int//min (hex "80000000") 0]
- [int//max (hex "7FFFFFFF") (hex "FFFFFFFF")]
+ [int//zero 0]
+ [int//one 1]
+ [int//min ("lux int min")]
+ [int//max ("lux int max")]
)
-(def: int64-high (r.nth (r.string //.int-high-field)))
-(def: int64-low (r.nth (r.string //.int-low-field)))
+(def: #export int64-high (r.nth (r.string //.int-high-field)))
+(def: #export int64-low (r.nth (r.string //.int-low-field)))
(runtime: (bit//not input)
(int//new (|> (@@ input) int64-high r.bit-not)
@@ -186,11 +213,18 @@
(new-half (@@ x16) (@@ x00))))))))
(runtime: (int//= reference sample)
- (let [comparison (: (-> (-> Expression Expression) Expression)
+ (let [n/a? (function (_ value)
+ (r.apply (list value) (r.global "is.na")))
+ isTRUE? (function (_ value)
+ (r.apply (list value) (r.global "isTRUE")))
+ comparison (: (-> (-> Expression Expression) Expression)
(function (_ field)
- (|> (field (@@ sample)) (r.= (field (@@ reference))))))]
+ (|> (|> (field (@@ sample)) (r.= (field (@@ reference))))
+ (r.or (|> (n/a? (field (@@ sample)))
+ (r.and (n/a? (field (@@ reference)))))))))]
(|> (comparison int64-high)
- (r.and (comparison int64-low)))))
+ (r.and (comparison int64-low))
+ isTRUE?)))
(runtime: (int//negate input)
(r.if (|> (@@ input) (int//= int//min))
@@ -432,9 +466,6 @@
(def: runtime//int
Runtime
($_ r.then
- @@int//unsigned-low
- @@int//to-float
- @@int//new
@@int//zero
@@int//one
@@int//min
@@ -443,11 +474,13 @@
@@int//<
@@int//+
@@int//-
+ @@int//negate
+ @@int//-one
+ @@int//unsigned-low
+ @@int//to-float
@@int//*
@@int///
- @@int//%
- @@int//negate
- @@int//from-float))
+ @@int//%))
(runtime: (lux//try op)
(with-vars [error value]
@@ -456,7 +489,8 @@
(..right (@@ value)))
#.None
(#.Some (r.function (list error)
- (..left (@@ error))))
+ (..left (r.nth (r.string "message")
+ (@@ error)))))
#.None)))
(runtime: (lux//program-args program-args)
@@ -590,20 +624,25 @@
(@@ count))))
(runtime: (bit//count input)
- (int//from-float (r.+ (int64-high (@@ input))
- (int64-low (@@ input)))))
+ (int//from-float (r.+ (bit//count-32 (int64-high (@@ input)))
+ (bit//count-32 (int64-low (@@ input))))))
(runtime: (bit//shift-right shift input)
($_ r.then
(limit-shift! shift)
(r.cond (list (no-shift-clause shift input)
[(|> (@@ shift) (r.< (r.int 32)))
- (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift)))))
- high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift)))
- low (|> (int64-low (@@ input))
- (r.bit-ushr (@@ shift))
- (r.bit-or mid))]
- (int//new high low))]
+ (with-vars [$mid]
+ (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift)))))
+ high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift)))
+ low (|> (int64-low (@@ input))
+ (r.bit-ushr (@@ shift))
+ (r.bit-or (r.if (r.apply (list (@@ $mid)) (r.global "is.na"))
+ (r.int 0)
+ (@@ $mid))))]
+ ($_ r.then
+ (r.set! $mid mid)
+ (int//new high low))))]
[(|> (@@ shift) (r.= (r.int 32)))
(let [high (int64-high (@@ input))]
(int//new (r.int 0) high))])
@@ -710,14 +749,14 @@
(r.set! pL (int//from-float (int64-low (@@ param))))
(r.set! pH (int//from-float (int64-high (@@ param))))
(let [bottom (bit//shift-right (r.int 32)
- (r.* (@@ pL) (@@ sL)))
- middle (r.+ (r.* (@@ pL) (@@ sH))
- (r.* (@@ pH) (@@ sL)))
- top (r.* (@@ pH) (@@ sH))]
+ (int//* (@@ pL) (@@ sL)))
+ middle (int//+ (int//* (@@ pL) (@@ sH))
+ (int//* (@@ pH) (@@ sL)))
+ top (int//* (@@ pH) (@@ sH))]
(|> bottom
- (r.+ middle)
+ (int//+ middle)
(bit//shift-right (r.int 32))
- (r.+ top))))))
+ (int//+ top))))))
(runtime: (deg//leading-zeroes input)
(with-vars [zeroes remaining]
@@ -740,7 +779,7 @@
(deg//leading-zeroes (@@ subject)))
(r.global "min")))
(let [subject' (|> (@@ subject) (bit//shift-left (@@ min-shift)))
- param' (|> (@@ param) (bit//shift-left (@@ min-shift)) int64-low int//from-float)]
+ param' (|> (@@ param) (bit//shift-left (@@ min-shift)) int64-high int//from-float)]
(|> subject'
(int/// param')
(bit//shift-left (r.int 32))))))))
@@ -755,12 +794,9 @@
(int//new high low)))))
(runtime: (deg//to-frac input)
- (with-vars [two32]
- ($_ r.then
- (r.set! two32 f2^32)
- (let [high (|> (int64-high (@@ input)) (r./ (@@ two32)))
- low (|> (int64-low (@@ input)) (r./ (@@ two32)) (r./ (@@ two32)))]
- (|> low (r.+ high))))))
+ (let [high (|> (int64-high (@@ input)) (r./ f2^32))
+ low (|> (int64-low (@@ input)) (r./ f2^32) (r./ f2^32))]
+ (|> low (r.+ high))))
(def: runtime//deg
Runtime
@@ -936,7 +972,9 @@
(def: (list-append! value rlist)
(-> Expression SVar Expression)
- (r.set-nth! (r.length (@@ rlist)) value rlist))
+ (r.set-nth! (|> (@@ rlist) r.length (r.+ (r.int 1)))
+ value
+ rlist))
(runtime: (process//loop _)
(let [empty (r.list (list))]
@@ -965,7 +1003,7 @@
(with-vars [start now seconds _arg elapsed-time]
($_ r.then
(r.set! start current-time-float)
- (r.set! seconds (to-seconds (@@ milli-seconds)))
+ (r.set! seconds (to-seconds (int//to-float (@@ milli-seconds))))
(list-append! (r.function (list _arg)
($_ r.then
(r.set! now current-time-float)
@@ -989,10 +1027,14 @@
(def: runtime
Runtime
($_ r.then
- runtime//int
runtime//lux
- runtime//adt
+ @@f2^32
+ @@f2^63
+ @@int//new
+ @@int//from-float
runtime//bit
+ runtime//int
+ runtime//adt
runtime//nat
runtime//deg
runtime//frac