diff options
author | Eduardo Julian | 2018-04-14 02:02:13 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-04-14 02:02:13 -0400 |
commit | 4ef2dbc49cd6dae1b8235dfd13dcd298c8aa3bfe (patch) | |
tree | db12bd62ab3e1c9767bfe43edc030e3bfc77ef95 /new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux | |
parent | ca238f9c89d3156842b0a3d5fe24a5d69b2eedb0 (diff) |
- Initial R back-end implementation.
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux | 1023 |
1 files changed, 1023 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux new file mode 100644 index 000000000..9b6d0c862 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux @@ -0,0 +1,1023 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [bit] + [number #+ hex] + text/format + (coll [list "list/" Monad<List>])) + [macro] + (macro [code] + ["s" syntax #+ syntax:]) + [io #+ Process]) + [//] + (luxc [lang] + (lang (host [r #+ SVar Expression Statement @@])))) + +(def: prefix Text "LuxRuntime") + +(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: #export (int value) + (-> Int Expression) + (r.named-list (list [//.int-high-field (r.int (high value))] + [//.int-low-field (r.int (low value))]))) + +(def: (flag value) + (-> Bool Expression) + (if value + (r.string "") + r.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (r.named-list (list [//.variant-tag-field tag] + [//.variant-flag-field last?] + [//.variant-value-field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression Expression) + (variant' (r.int (nat-to-int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant +0 false unit)) + +(def: #export some + (-> Expression Expression) + (variant +1 true)) + +(def: #export left + (-> Expression Expression) + (variant +0 false)) + +(def: #export right + (-> Expression Expression) + (variant +1 true)) + +(type: Runtime Statement) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: [[name args] declaration] + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (format prefix "__" (lang.normalize-name name)) + $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) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression))) + r.Expression))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (r.apply (list (~+ argsC+)) (~ @runtime)))) + (` (def: (~ implementation) + r.Statement + (~ (case argsC+ + #.Nil + (` (r.set! (~ $runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (r.set! (~ $runtime) + (r.function (list (~+ argsLC+)) + (~ definition))))))))))))) + +(syntax: #export (with-vars [vars (s.tuple (p.many s.local-symbol))] + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol var) + (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) + list/join))] + (~ body)))))) + +(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)))) + +(def: (as-integer value) + (-> Expression Expression) + (r.apply (list value) (r.global "as.integer"))) + +(runtime: (int//unsigned-low input) + (with-vars [low] + ($_ r.then! + (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field)))) + (r.do! + (r.if (|> (@@ low) (r.>= (r.int 0))) + (@@ low) + (|> (@@ low) (r.+ f2^32))))))) + +(runtime: (int//to-float input) + (let [high (|> (@@ input) + (r.nth (r.string //.int-high-field)) + high-shift) + low (|> (@@ input) + int//unsigned-low)] + (r.do! (|> high (r.+ low))))) + +(runtime: (int//new high low) + (r.do! + (r.named-list (list [//.int-high-field (as-integer (@@ high))] + [//.int-low-field (as-integer (@@ low))])))) + +(do-template [<name> <high> <low>] + [(runtime: <name> + (int//new (r.int <high>) (r.int <low>)))] + + [int//zero 0 0] + [int//one 0 1] + [int//min (hex "80000000") 0] + [int//max (hex "7FFFFFFF") (hex "FFFFFFFF")] + ) + +(def: int64-high (r.nth (r.string //.int-high-field))) +(def: int64-low (r.nth (r.string //.int-low-field))) + +(runtime: (bit//not input) + (r.do! (int//new (|> (@@ input) int64-high r.bit-not) + (|> (@@ input) int64-low r.bit-not)))) + +(runtime: (int//+ param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then! + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pH (|> (@@ param) int64-high)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + + [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL)) + [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL)) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom))))] + ($_ r.then! + (r.set! x00 (|> s00 (r.+ p00))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16))) + (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32))) + (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48))) + (r.do! (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00))))))))) + +(runtime: (int//= reference sample) + (let [comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (field (@@ sample)) (r.= (field (@@ reference))))))] + (r.do! (|> (comparison int64-high) + (r.and (comparison int64-low)))))) + +(runtime: (int//negate input) + (r.do! + (r.if (|> (@@ input) (int//= int//min)) + int//min + (|> (@@ input) bit//not (int//+ int//one))))) + +(runtime: int//-one + (int//negate int//one)) + +(runtime: (int//- param subject) + (r.do! (int//+ (int//negate (@@ param)) (@@ subject)))) + +(runtime: (int//< reference sample) + (with-vars [r-? s-?] + ($_ r.then! + (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0)))) + (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0)))) + (r.do! (|> (|> (@@ s-?) (r.and (r.not (@@ r-?)))) + (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not)) + (r.or (|> (@@ sample) + (int//- (@@ reference)) + int64-high + (r.< (r.int 0))))))))) + +(runtime: (int//from-float input) + (r.do! + (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan")) + int//zero] + [(|> (@@ input) (r.<= (r.negate f2^63))) + int//min] + [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63)) + int//max] + [(|> (@@ input) (r.< (r.float 0.0))) + (|> (@@ input) r.negate int//from-float int//negate)]) + (int//new (|> (@@ input) (r./ f2^32)) + (|> (@@ input) (r.%% f2^32)))))) + +(runtime: (int//* param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then! + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! pH (|> (@@ param) int64-high)) + (let [negative-subject? (|> (@@ sH) (r.< (r.int 0))) + negative-param? (|> (@@ pH) (r.< (r.int 0)))] + (r.cond! (list [negative-subject? + (r.if! negative-param? + (r.do! (int//* (int//negate (@@ param)) + (int//negate (@@ subject)))) + (r.do! (int//negate (int//* (@@ param) + (int//negate (@@ subject))))))] + + [negative-param? + (r.do! (int//negate (int//* (int//negate (@@ param)) + (@@ subject))))]) + ($_ r.then! + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom)))) + + [[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL)) + [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL)) + x16-top (|> (@@ x16) top-16) + x32-top (|> (@@ x32) top-16)] + (with-vars [s48 s32 s16 s00 + p48 p32 p16 p00] + ($_ r.then! + (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00) + (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00) + (r.set! x00 (|> (@@ s00) (r.* (@@ p00)))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00)))))) + (r.set! x32 x16-top) + (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16)))))) + (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00)))))) + (r.set! x48 x32-top) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top))) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top) + (r.+ (|> (@@ s48) (r.* (@@ p00)))) + (r.+ (|> (@@ s32) (r.* (@@ p16)))) + (r.+ (|> (@@ s16) (r.* (@@ p32)))) + (r.+ (|> (@@ s00) (r.* (@@ p48)))))) + (r.do! (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00)))))) + ))))))) + +(def: (limit-shift! shift) + (-> SVar Statement) + (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63))))) + +(def: (no-shift-clause shift input) + (-> SVar SVar [Expression Statement]) + [(|> (@@ shift) (r.= (r.int 0))) + (r.do! (@@ input))]) + +(runtime: (bit//shift-left shift input) + ($_ r.then! + (limit-shift! shift) + (r.cond! (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) + (r.bit-shl (@@ shift)) + (r.bit-or mid)) + low (|> (int64-low (@@ input)) + (r.bit-shl (@@ shift)))] + (r.do! (int//new high low)))]) + (let [high (|> (int64-high (@@ input)) + (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))] + (r.do! (int//new high (r.int 0))))))) + +(runtime: (bit//signed-shift-right-32 shift input) + (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))] + (r.do! (|> (@@ input) + (r.bit-ushr (@@ shift)) + (r.bit-or top-bit))))) + +(runtime: (bit//signed-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)) + (bit//signed-shift-right-32 (@@ shift))) + low (|> (int64-low (@@ input)) + (r.bit-ushr (@@ shift)) + (r.bit-or mid))] + (r.do! (int//new high low)))]) + (let [low (|> (int64-high (@@ input)) + (bit//signed-shift-right-32 (|> (@@ shift) (r.- (r.int 32))))) + high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0))) + (r.int 0) + (r.int -1))] + (r.do! (int//new high low)))))) + +(runtime: (int/// param subject) + (let [negative? (|>> (int//< int//zero)) + valid-division-check [(|> (@@ param) (int//= int//zero)) + (r.stop! (r.string "Cannot divide by zero!"))] + short-circuit-check [(|> (@@ subject) (int//= int//zero)) + (r.do! int//zero)]] + (r.cond! (list valid-division-check + short-circuit-check + + [(|> (@@ subject) (int//= int//min)) + (r.cond! (list [(|> (|> (@@ param) (int//= int//one)) + (r.or (|> (@@ param) (int//= int//-one)))) + (r.do! int//min)] + [(|> (@@ param) (int//= int//min)) + (r.do! int//one)]) + (with-vars [approximation] + ($_ r.then! + (r.set! approximation + (|> (@@ subject) + (bit//signed-shift-right (r.int 1)) + (int/// (@@ param)) + (bit//shift-left (r.int 1)))) + (r.if! (|> (@@ approximation) (int//= int//zero)) + (r.do! (r.if (negative? (@@ param)) + int//one + int//-one)) + (let [remainder (int//- (int//* (@@ param) (@@ approximation)) + (@@ subject))] + (r.do! (|> remainder + (int/// (@@ param)) + (int//+ (@@ approximation)))))))))] + [(|> (@@ param) (int//= int//min)) + (r.do! int//zero)] + + [(negative? (@@ subject)) + (r.do! (r.if (negative? (@@ param)) + (|> (int//negate (@@ subject)) + (int/// (int//negate (@@ param)))) + (|> (int//negate (@@ subject)) + (int/// (@@ param)) + int//negate)))] + + [(negative? (@@ param)) + (r.do! (|> (@@ param) + int//negate + (int/// (@@ subject)) + int//negate))]) + (with-vars [result remainder approximate approximate-result log2 approximate-remainder] + ($_ r.then! + (r.set! result int//zero) + (r.set! remainder (@@ subject)) + (r.while! (|> (|> (@@ remainder) (int//< (@@ param))) + (r.or (|> (@@ remainder) (int//= (@@ param))))) + (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param))))) + (r.global "floor")) + calc-approximate-result (int//from-float (@@ approximate)) + calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param))) + delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) + (r.float 1.0) + (r.** (|> (@@ log2) (r.- (r.float 48.0))) + (r.float 2.0)))] + ($_ r.then! + (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate) + (r.global "max"))) + (r.set! log2 (let [log (function (_ input) + (r.apply (list input) (r.global "log")))] + (r.apply (list (|> (log (r.int 2)) + (r./ (log (@@ approximate))))) + (r.global "ceil")))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder) + (r.while! (|> (negative? (@@ approximate-remainder)) + (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) + ($_ r.then! + (r.set! approximate (|> delta (r.- (@@ approximate)))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder))) + (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero)) + int//one + (@@ approximate-result)) + (int//+ (@@ result)))) + (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder))))))) + (r.do! (@@ result)))) + ))) + +(runtime: (int//% param subject) + (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))] + (r.do! (|> (@@ subject) (int//- flat))))) + +(def: runtime//int + Runtime + ($_ r.then! + @@int//unsigned-low + @@int//to-float + @@int//new + @@int//zero + @@int//one + @@int//min + @@int//max + @@int//= + @@int//< + @@int//+ + @@int//- + @@int//* + @@int/// + @@int//% + @@int//negate + @@int//from-float)) + +(runtime: (lux//try op) + (with-vars [error value] + (r.do! (r.try ($_ r.then! + (r.set! value (r.apply (list ..unit) (@@ op))) + (r.do! (..right (@@ value)))) + #.None + (#.Some (r.function (list error) + (r.do! (..left (@@ error))))) + #.None)))) + +(runtime: (lux//program-args program-args) + (with-vars [inputs value] + ($_ r.then! + (r.set! inputs ..none) + (<| (r.for-in! value (@@ program-args)) + (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs)))))) + (r.do! (@@ inputs))))) + +(def: runtime//lux + Runtime + ($_ r.then! + @@lux//try + @@lux//program-args)) + +(def: current-time-float + Expression + (let [raw-time (r.apply (list) (r.global "Sys.time"))] + (r.apply (list raw-time) (r.global "as.numeric")))) + +(runtime: (io//current-time! _) + (r.do! (|> current-time-float + (r.* (r.float 1_000.0)) + int//from-float))) + +(def: runtime//io + Runtime + ($_ r.then! + @@io//current-time!)) + +(def: minimum-index-length + (-> SVar Expression) + (|>> @@ (r.+ (r.int 1)))) + +(def: (product-element product index) + (-> Expression Expression Expression) + (|> product (r.nth (|> index (r.+ (r.int 1)))))) + +(def: (product-tail product) + (-> SVar Expression) + (|> (@@ product) (r.nth (r.length (@@ product))))) + +(def: (updated-index min-length product) + (-> Expression Expression Expression) + (|> min-length (r.- (r.length product)))) + +(runtime: (product//left product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then! + (r.set! $index_min_length (minimum-index-length index)) + (r.do! (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length))) + ## No need for recursion + (product-element (@@ product) (@@ index)) + ## Needs recursion + (product//left (product-tail product) + (updated-index (@@ $index_min_length) (@@ product)))))))) + +(runtime: (product//right product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then! + (r.set! $index_min_length (minimum-index-length index)) + (r.do! (r.cond (list [## Last element. + (|> (r.length (@@ product)) (r.= (@@ $index_min_length))) + (product-element (@@ product) (@@ index))] + [## Needs recursion + (|> (r.length (@@ product)) (r.< (@@ $index_min_length))) + (product//right (product-tail product) + (updated-index (@@ $index_min_length) (@@ product)))]) + ## Must slice + (|> (@@ product) (r.slice-from (@@ index)))))))) + +(runtime: (sum//get sum wanted_tag wants_last) + (let [no-match r.null + sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field))) + sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field))) + sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field))) + is-last? (|> sum-flag (r.= (r.string ""))) + test-recursion (r.if is-last? + ## Must recurse. + (sum//get sum-value + (|> (@@ wanted_tag) (r.- sum-tag)) + (@@ wants_last)) + no-match)] + (r.do! (r.cond (list [(r.= sum-tag (@@ wanted_tag)) + (r.if (r.= (@@ wants_last) sum-flag) + sum-value + test-recursion)] + + [(|> (@@ wanted_tag) (r.> sum-tag)) + test-recursion] + + [(|> (|> (@@ wants_last) (r.= (r.string ""))) + (r.and (|> (@@ wanted_tag) (r.< sum-tag)))) + (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)]) + + no-match)))) + +(def: runtime//adt + Runtime + ($_ r.then! + @@product//left + @@product//right + @@sum//get + )) + +(do-template [<name> <op>] + [(runtime: (<name> mask input) + (r.do! (int//new (<op> (int64-high (@@ mask)) + (int64-high (@@ input))) + (<op> (int64-low (@@ mask)) + (int64-low (@@ input))))))] + + [bit//and r.bit-and] + [bit//or r.bit-or] + [bit//xor r.bit-xor] + ) + +(runtime: (bit//count-32 input) + (with-vars [count] + ($_ r.then! + (r.set! count (r.int 0)) + (let [last-input-bit (|> (@@ input) (r.bit-and (r.int 1))) + update-count! (r.set! count (|> (@@ count) (r.+ last-input-bit))) + consume-input! (r.set! input (|> (@@ input) (r.bit-ushr (r.int 1)))) + input-remaining? (|> (@@ input) (r.= (r.int 0)))] + (r.while! input-remaining? + ($_ r.then! + update-count! + consume-input!))) + (r.do! (@@ count))))) + +(runtime: (bit//count input) + (r.do! (int//from-float (r.+ (int64-high (@@ input)) + (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))] + (r.do! (int//new high low)))] + [(|> (@@ shift) (r.= (r.int 32))) + (let [high (int64-high (@@ input))] + (r.do! (int//new (r.int 0) high)))]) + (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))] + (r.do! (int//new (r.int 0) low)))))) + +(def: runtime//bit + Runtime + ($_ r.then! + @@bit//and + @@bit//or + @@bit//xor + @@bit//not + @@bit//count-32 + @@bit//count + @@bit//shift-left + @@bit//signed-shift-right-32 + @@bit//signed-shift-right + @@bit//shift-right + )) + +(runtime: (nat//< param subject) + (with-vars [pH sH] + ($_ r.then! + (r.set! pH (..int64-high (@@ param))) + (r.set! sH (..int64-high (@@ subject))) + (let [lesser-high? (|> (@@ sH) (r.< (@@ pH))) + equal-high? (|> (@@ sH) (r.= (@@ pH))) + lesser-low? (|> (..int64-low (@@ subject)) (r.< (..int64-low (@@ param))))] + (r.do! (|> lesser-high? + (r.or (|> equal-high? + (r.and lesser-low?))))))))) + +(runtime: (nat/// parameter subject) + (let [negative? (int//< int//zero) + valid-division-check [(|> (@@ parameter) (int//= int//zero)) + (r.stop! (r.string "Cannot divide by zero!"))] + short-circuit-check [(|> (@@ subject) (nat//< (@@ parameter))) + (r.do! int//zero)]] + (r.cond! (list valid-division-check + short-circuit-check + + [(|> (@@ parameter) + (nat//< (|> (@@ subject) (bit//shift-right (r.int 1))))) + (r.do! int//one)]) + (with-vars [result remainder approximate log2 approximate-result approximate-remainder delta] + ($_ r.then! + (r.set! result int//zero) + (r.set! remainder (@@ subject)) + (r.while! (|> (|> (@@ remainder) (nat//< (@@ parameter))) + (r.or (|> (@@ remainder) (int//= (@@ parameter))))) + (let [rough-estimate (r.apply (list (|> (int//to-float (@@ parameter)) (r./ (int//to-float (@@ remainder))))) + (r.global "floor")) + calculate-approximate-result (int//from-float (@@ approximate)) + calculate-approximate-remainder (int//* (@@ parameter) (@@ approximate-result)) + delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) + (r.float 1.0) + (r.** (|> (r.float 48.0) (r.- (@@ log2))) + (r.float 2.0))) + update-approximates! ($_ r.then! + (r.set! approximate-result calculate-approximate-result) + (r.set! approximate-remainder calculate-approximate-remainder))] + ($_ r.then! + (r.set! approximate (r.apply (list (r.float 1.0) rough-estimate) + (r.global "max"))) + (r.set! log2 (let [log (function (_ input) + (r.apply (list input) (r.global "log")))] + (r.apply (list (|> (log (r.int 2)) + (r./ (log (@@ approximate))))) + (r.global "ceil")))) + update-approximates! + (r.while! (|> (negative? (@@ approximate-remainder)) + (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) + ($_ r.then! + (r.set! approximate (|> delta (r.- (@@ approximate)))) + update-approximates!)) + ($_ r.then! + (r.set! result (|> (@@ result) + (int//+ (r.if (|> (@@ approximate-result) (int//= int//zero)) + int//one + (@@ approximate-result))))) + (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder)))))))) + (r.do! (@@ result)))) + ))) + +(runtime: (nat//% param subject) + (let [flat (|> (@@ subject) + (nat/// (@@ param)) + (int//* (@@ param)))] + (r.do! (|> (@@ subject) (int//- flat))))) + +(def: runtime//nat + Runtime + ($_ r.then! + @@nat//< + @@nat/// + @@nat//%)) + +(runtime: (deg//* param subject) + (with-vars [sL sH pL pH bottom middle top] + ($_ r.then! + (r.set! sL (int//from-float (int64-low (@@ subject)))) + (r.set! sH (int//from-float (int64-high (@@ subject)))) + (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))] + (r.do! (|> bottom + (r.+ middle) + (bit//shift-right (r.int 32)) + (r.+ top))))))) + +(runtime: (deg//leading-zeroes input) + (with-vars [zeroes remaining] + ($_ r.then! + (r.set! zeroes (r.int 64)) + (r.set! remaining (@@ input)) + (r.while! (|> (@@ remaining) (int//= int//zero) r.not) + ($_ r.then! + (r.set! zeroes (|> (@@ zeroes) (r.- (r.int 1)))) + (r.set! remaining (|> (@@ remaining) (bit//shift-right (r.int 1)))))) + (r.do! (@@ zeroes))))) + +(runtime: (deg/// param subject) + (with-vars [min-shift] + (r.if! (|> (@@ subject) (int//= (@@ param))) + (r.do! int//-one) + ($_ r.then! + (r.set! min-shift + (r.apply (list (deg//leading-zeroes (@@ param)) + (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)] + (r.do! (|> subject' + (int/// param') + (bit//shift-left (r.int 32))))))))) + +(runtime: (deg//from-frac input) + (with-vars [two32 shifted] + ($_ r.then! + (r.set! two32 (|> (r.float 2.0) (r.** (r.float 32.0)))) + (r.set! shifted (|> (@@ input) (r.%% (r.float 1.0)) (r.* (@@ two32)))) + (let [low (|> (@@ shifted) (r.%% (r.float 1.0)) (r.* (@@ two32)) as-integer) + high (|> (@@ shifted) as-integer)] + (r.do! (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)))] + (r.do! (|> low (r.+ high))))))) + +(def: runtime//deg + Runtime + ($_ r.then! + @@deg//* + @@deg//leading-zeroes + @@deg/// + @@deg//from-frac + @@deg//to-frac)) + +(runtime: (frac//decode input) + (with-vars [output] + ($_ r.then! + (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric"))) + (r.do! (r.if (|> (@@ output) (r.= r.n/a)) + ..none + (..some (@@ output))))))) + +(def: runtime//frac + Runtime + ($_ r.then! + @@frac//decode)) + +(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1)))) + +(do-template [<name> <top-cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (|> (|> value (r.>= (r.int 0))) + (r.and (|> value (<top-cmp> top)))))] + + [within? r.<] + [up-to? r.<=] + ) + +(def: (text-clip start end text) + (-> Expression Expression Expression Expression) + (r.apply (list text start end) + (r.global "substr"))) + +(def: (text-length text) + (-> Expression Expression) + (r.apply (list text) (r.global "nchar"))) + +(runtime: (text//index subject param start) + (with-vars [idx startF subjectL] + ($_ r.then! + (r.set! startF (int//to-float (@@ start))) + (r.set! subjectL (text-length (@@ subject))) + (r.do! + (r.if (|> (@@ startF) (within? (@@ subjectL))) + (r.block + ($_ r.then! + (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0))) + (@@ subject) + (text-clip (inc (@@ startF)) + (inc (@@ subjectL)) + (@@ subject)))) + (list ["fixed" (r.bool true)]) + (r.global "regexpr")) + (r.nth (r.int 1)))) + (r.do! + (r.if (|> (@@ idx) (r.= (r.int -1))) + ..none + (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF))))))))) + ..none))))) + +(runtime: (text//clip text from to) + (with-vars [length] + ($_ r.then! + (r.set! length (r.length (@@ text))) + (r.do! + (r.if ($_ r.and + (|> (@@ to) (within? (@@ length))) + (|> (@@ from) (up-to? (@@ to)))) + (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text))) + ..none))))) + +(def: (char-at idx text) + (-> Expression Expression Expression) + (r.apply (list (text-clip idx idx text)) + (r.global "utf8ToInt"))) + +(runtime: (text//char text idx) + (r.if! (|> (@@ idx) (within? (r.length (@@ text)))) + ($_ r.then! + (r.set! idx (inc (@@ idx))) + (r.do! (..some (int//from-float (char-at (@@ idx) (@@ text)))))) + (r.do! ..none))) + +(runtime: (text//hash input) + (let [bits-32 (r.code "0xFFFFFFFF")] + (with-vars [idx hash] + ($_ r.then! + (r.set! hash (r.int 0)) + (r.for-in! idx (r.range (r.int 1) (text-length (@@ input))) + (r.set! hash (|> (@@ hash) + (r.bit-shl (r.int 5)) + (r.- (@@ hash)) + (r.+ (char-at (@@ idx) (@@ input))) + (r.bit-and bits-32)))) + (r.do! (int//from-float (@@ hash))))))) + +(def: runtime//text + Runtime + ($_ r.then! + @@text//index + @@text//clip + @@text//char + @@text//hash)) + +(def: (check-index-out-of-bounds array idx body!) + (-> Expression Expression Statement Statement) + (r.if! (|> idx (r.<= (r.length array))) + body! + (r.stop! (r.string "Array index out of bounds!")))) + +(runtime: (array//new size) + (with-vars [output] + ($_ r.then! + (r.set! output (r.list (list))) + (r.set-nth! (|> (@@ size) (r.+ (r.int 1))) + r.null + output) + (r.do! (@@ output))))) + +(runtime: (array//get array idx) + (with-vars [temp] + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then! + (r.set! temp (|> (@@ array) (r.nth (@@ idx)))) + (r.if! (|> (@@ temp) (r.= r.null)) + (r.do! ..none) + (r.do! (..some (@@ temp)))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then! + (r.set-nth! (@@ idx) (@@ value) array) + (r.do! (@@ array))))) + +(def: runtime//array + Runtime + ($_ r.then! + @@array//new + @@array//get + @@array//put)) + +(def: #export atom//field Text "lux_atom") + +(runtime: (atom//compare-and-swap atom old new) + (let [atom//field (r.string atom//field)] + (r.do! + (r.if (|> (@@ atom) (r.nth atom//field) (r.= (@@ old))) + (r.block + ($_ r.then! + (r.set-nth! atom//field (@@ new) atom) + (r.do! (r.bool true)))) + (r.bool false))))) + +(def: runtime//atom + Runtime + ($_ r.then! + @@atom//compare-and-swap)) + +(runtime: (box//write value box) + ($_ r.then! + (r.set-nth! (r.int 1) (@@ value) box) + (r.do! ..unit))) + +(def: runtime//box + Runtime + ($_ r.then! + @@box//write)) + +(def: process//incoming + SVar + (r.var (lang.normalize-name "process//incoming"))) + +(def: (list-append! value rlist) + (-> Expression SVar Statement) + (r.set-nth! (r.length (@@ rlist)) value rlist)) + +(runtime: (process//loop _) + (let [empty (r.list (list))] + (with-vars [queue process] + (let [migrate-incoming! ($_ r.then! + (r.set! queue empty) + (<| (r.for-in! process (@@ process//incoming)) + (list-append! (@@ process) queue)) + (r.set! process//incoming empty)) + consume-queue! (<| (r.for-in! process (@@ queue)) + (r.do! (r.apply (list ..unit) (@@ process))))] + ($_ r.then! + migrate-incoming! + consume-queue! + (r.when! (|> (r.length (@@ queue)) (r.> (r.int 0))) + (r.do! (process//loop ..unit)))))))) + +(runtime: (process//future procedure) + ($_ r.then! + (list-append! (@@ procedure) process//incoming) + (r.do! ..unit))) + +(runtime: (process//schedule milli-seconds procedure) + (let [to-seconds (|>> (r./ (r.float 1_000.0))) + to-millis (|>> (r.* (r.float 1_000.0)))] + (with-vars [start now seconds _arg elapsed-time] + ($_ r.then! + (r.set! start current-time-float) + (r.set! seconds (to-seconds (@@ milli-seconds))) + (list-append! (r.function (list _arg) + ($_ r.then! + (r.set! now current-time-float) + (r.set! elapsed-time (|> (@@ now) (r.- (@@ start)))) + (r.if! (|> (@@ elapsed-time) (r.>= (@@ seconds))) + (r.do! (@@ procedure)) + (r.do! (process//schedule (to-millis (@@ elapsed-time)) + (@@ procedure)))))) + process//incoming) + (r.do! ..unit))))) + +(def: runtime//process + Runtime + ($_ r.then! + (r.set! process//incoming (r.list (list))) + @@process//loop + @@process//future + @@process//schedule + )) + +(def: runtime + Runtime + ($_ r.then! + runtime//int + runtime//lux + runtime//adt + runtime//bit + runtime//nat + runtime//deg + runtime//frac + runtime//text + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + )) + +(def: #export artifact Text (format prefix ".r")) + +(def: #export translate + (Meta (Process Unit)) + (do macro.Monad<Meta> + [_ //.init-module-buffer + _ (//.save runtime)] + (//.save-module! artifact))) |