aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2020-07-07 00:43:36 -0400
committerEduardo Julian2020-07-07 00:43:36 -0400
commit509259d91b07bce77864cf10123ce428461a3092 (patch)
treefb698ebe86e101a33cb350d2d6ea878a723c11f8 /stdlib/source
parent5e45337f2829376a552d4ff26121125c135aa2b7 (diff)
Various bug fixes for JS compilation.
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux132
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux250
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux27
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux4
5 files changed, 228 insertions, 203 deletions
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 0b811a7b7..f162cc157 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -372,73 +372,73 @@
(:assume
((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})]
(do (try.with promise.monad)
- [#let [parallel-compiler (..parallel
- context
- (function (_ import! module-id [archive state] module)
- (do (try.with promise.monad)
- [#let [state (..set-current-module module state)]
- input (context.read (get@ #&file-system platform)
- import
- compilation-sources
- (get@ #static.host-module-extension static)
- module)]
- (loop [[archive state] [archive state]
- compilation (base-compiler (:coerce ///.Input input))
- all-dependencies (: (List Module)
- (list))]
- (do {@ (try.with promise.monad)}
- [#let [new-dependencies (get@ #///.dependencies compilation)
- all-dependencies (list@compose new-dependencies all-dependencies)
- continue! (:share [<type-vars>]
- {<Platform>
- platform}
- {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
- (Action [Archive <State+>]))
- (:assume
- recur)})]
- [archive state] (case new-dependencies
- #.Nil
- (wrap [archive state])
+ [#let [compiler (..parallel
+ context
+ (function (_ import! module-id [archive state] module)
+ (do (try.with promise.monad)
+ [#let [state (..set-current-module module state)]
+ input (context.read (get@ #&file-system platform)
+ import
+ compilation-sources
+ (get@ #static.host-module-extension static)
+ module)]
+ (loop [[archive state] [archive state]
+ compilation (base-compiler (:coerce ///.Input input))
+ all-dependencies (: (List Module)
+ (list))]
+ (do {@ (try.with promise.monad)}
+ [#let [new-dependencies (get@ #///.dependencies compilation)
+ all-dependencies (list@compose new-dependencies all-dependencies)
+ continue! (:share [<type-vars>]
+ {<Platform>
+ platform}
+ {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+ (Action [Archive <State+>]))
+ (:assume
+ recur)})]
+ [archive state] (case new-dependencies
+ #.Nil
+ (wrap [archive state])
- (#.Cons _)
- (do @
- [archive,document+ (|> new-dependencies
- (list@map import!)
- (monad.seq ..monad))
- #let [archive (|> archive,document+
- (list@map product.left)
- (list@fold archive.merge archive))]]
- (wrap [archive (try.assume
- (..updated-state archive state))])))]
- (case ((get@ #///.process compilation)
- ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
- ## TODO: The context shouldn't need to be re-set either.
- (|> (///directive.set-current-module module)
- (///phase.run' state)
- try.assume
- product.left)
- archive)
- (#try.Success [state more|done])
- (case more|done
- (#.Left more)
- (continue! [archive state] more all-dependencies)
+ (#.Cons _)
+ (do @
+ [archive,document+ (|> new-dependencies
+ (list@map import!)
+ (monad.seq ..monad))
+ #let [archive (|> archive,document+
+ (list@map product.left)
+ (list@fold archive.merge archive))]]
+ (wrap [archive (try.assume
+ (..updated-state archive state))])))]
+ (case ((get@ #///.process compilation)
+ ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The context shouldn't need to be re-set either.
+ (|> (///directive.set-current-module module)
+ (///phase.run' state)
+ try.assume
+ product.left)
+ archive)
+ (#try.Success [state more|done])
+ (case more|done
+ (#.Left more)
+ (continue! [archive state] more all-dependencies)
- (#.Right [[descriptor document] output])
- (do (try.with promise.monad)
- [#let [_ (log! (..module-compilation-log state))
- descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
- _ (..cache-module static platform module-id [[descriptor document] output])]
- (case (archive.add module [descriptor document] archive)
- (#try.Success archive)
- (wrap [archive
- (..with-reset-log state)])
-
- (#try.Failure error)
- (promise@wrap (#try.Failure error)))))
+ (#.Right [[descriptor document] output])
+ (do (try.with promise.monad)
+ [#let [_ (log! (..module-compilation-log state))
+ descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
+ _ (..cache-module static platform module-id [[descriptor document] output])]
+ (case (archive.add module [descriptor document] archive)
+ (#try.Success archive)
+ (wrap [archive
+ (..with-reset-log state)])
+
+ (#try.Failure error)
+ (promise@wrap (#try.Failure error)))))
- (#try.Failure error)
- (do (try.with promise.monad)
- [_ (ioW.freeze (get@ #&file-system platform) static archive)]
- (promise@wrap (#try.Failure error)))))))))]]
- (parallel-compiler compilation-module))))
+ (#try.Failure error)
+ (do (try.with promise.monad)
+ [_ (ioW.freeze (get@ #&file-system platform) static archive)]
+ (promise@wrap (#try.Failure error)))))))))]]
+ (compiler compilation-module))))
))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux
index 1dc91abe2..700411c5f 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux
@@ -3,7 +3,7 @@
[abstract
["." monad (#+ do)]]
[control
- ["ex" exception (#+ exception:)]]
+ ["." exception (#+ exception:)]]
[data
["." maybe]
["." text]
@@ -138,125 +138,145 @@
..restore-cursor!
post!)))
-(def: (pattern-matching' generate archive)
- (-> Phase Archive
- (-> Path (Operation Statement)))
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (do ///////phase.monad
- [body! (generate archive bodyS)]
- (wrap (_.return body!)))
-
- #/////synthesis.Pop
- (///////phase@wrap pop-cursor!)
-
- (#/////synthesis.Bind register)
- (///////phase@wrap (_.define (..register register) ..peek-cursor))
-
- (#/////synthesis.Bit-Fork when thenP elseP)
- (do {@ ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail-pm!))]
- (wrap (.if when
- (_.if ..peek-cursor
- then!
- else!)
- (_.if ..peek-cursor
- else!
- then!))))
-
- (#/////synthesis.I64-Fork cons)
- (do {@ ///////phase.monad}
- [clauses (monad.map @ (function (_ [match then])
- (do @
- [then! (recur then)]
- (wrap [(//runtime.i64//= (//primitive.i64 (.int match))
- ..peek-cursor)
- then!])))
- (#.Cons cons))]
- (wrap (_.cond clauses ..fail-pm!)))
-
- (^template [<tag> <format> <type>]
- (<tag> cons)
- (do {@ ///////phase.monad}
- [cases (monad.map @ (function (_ [match then])
- (:: @ map (|>> [(list (<format> match))]) (recur then)))
- (#.Cons cons))]
- (wrap (_.switch ..peek-cursor
- cases
- (#.Some ..fail-pm!)))))
- ([#/////synthesis.F64-Fork //primitive.f64 Frac]
- [#/////synthesis.Text-Fork //primitive.text Text])
-
- (^template [<complex> <simple> <choice>]
- (^ (<complex> idx))
- (///////phase@wrap (<choice> false idx))
-
- (^ (<simple> idx nextP))
- (|> nextP
- recur
- (:: ///////phase.monad map (_.then (<choice> true idx)))))
- ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice]
- [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase@wrap (push-cursor! (_.at (_.i32 +0) ..peek-cursor)))
-
- ## Extra optimization
+(def: (optimized-pattern-matching recur generate archive pathP)
+ (-> (-> Path (Operation Statement)) Phase Archive
+ (-> Path (Operation (Maybe Statement))))
+ (.case pathP
+ (^template [<simple> <choice>]
+ (^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (:: ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some))))
+ ([/////synthesis.simple-left-side ..left-choice]
+ [/////synthesis.simple-right-side ..right-choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase@wrap (#.Some (push-cursor! (_.at (_.i32 +0) ..peek-cursor))))
+
+ ## Extra optimization
+ (^ (/////synthesis.path/seq
+ (/////synthesis.member/left 0)
+ (/////synthesis.!bind-top register thenP)))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor))
+ then!))))
+
+ ## Extra optimization
+ (^template [<pm> <getter>]
(^ (/////synthesis.path/seq
- (/////synthesis.member/left 0)
+ (<pm> lefts)
(/////synthesis.!bind-top register thenP)))
(do ///////phase.monad
[then! (recur thenP)]
- (///////phase@wrap ($_ _.then
- (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor))
- then!)))
-
- (^template [<pm> <getter>]
- (^ (<pm> lefts))
- (///////phase@wrap (push-cursor! (<getter> (_.i32 (.int lefts)) ..peek-cursor)))
-
- ## Extra optimization
- (^ (/////synthesis.path/seq
- (<pm> lefts)
- (/////synthesis.!bind-top register thenP)))
- (do ///////phase.monad
- [then! (recur thenP)]
- (///////phase@wrap ($_ _.then
- (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek-cursor))
- then!))))
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!bind-top register thenP))
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek-cursor))
+ then!)))))
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!bind-top register thenP))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) ..peek-and-pop-cursor)
+ then!))))
+
+ (^ (/////synthesis.!multi-pop nextP))
+ (.let [[extra-pops nextP'] (////synthesis/case.count-pops nextP)]
(do ///////phase.monad
- [then! (recur thenP)]
- (///////phase@wrap ($_ _.then
- (_.define (..register register) ..peek-and-pop-cursor)
- then!)))
-
- (^ (/////synthesis.!multi-pop nextP))
- (.let [[extra-pops nextP'] (////synthesis/case.count-pops nextP)]
- (do ///////phase.monad
- [next! (recur nextP')]
- (///////phase@wrap ($_ _.then
- (multi-pop-cursor! (n.+ 2 extra-pops))
- next!))))
-
- (^template [<tag> <combinator>]
- (^ (<tag> leftP rightP))
- (do ///////phase.monad
- [left! (recur leftP)
- right! (recur rightP)]
- (wrap (<combinator> left! right!))))
- ([/////synthesis.path/seq _.then]
- [/////synthesis.path/alt alternation]))))
+ [next! (recur nextP')]
+ (wrap (#.Some ($_ _.then
+ (multi-pop-cursor! (n.+ 2 extra-pops))
+ next!)))))
+
+ _
+ (///////phase@wrap #.None)))
+
+(def: (pattern-matching' generate archive)
+ (-> Phase Archive
+ (-> Path (Operation Statement)))
+ (function (recur pathP)
+ (do ///////phase.monad
+ [outcome (optimized-pattern-matching recur generate archive pathP)]
+ (.case outcome
+ (#.Some outcome)
+ (wrap outcome)
+
+ #.None
+ (.case pathP
+ #/////synthesis.Pop
+ (///////phase@wrap pop-cursor!)
+
+ (#/////synthesis.Bind register)
+ (///////phase@wrap (_.define (..register register) ..peek-cursor))
+
+ (#/////synthesis.Bit-Fork when thenP elseP)
+ (do {@ ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail-pm!))]
+ (wrap (.if when
+ (_.if ..peek-cursor
+ then!
+ else!)
+ (_.if ..peek-cursor
+ else!
+ then!))))
+
+ (#/////synthesis.I64-Fork cons)
+ (do {@ ///////phase.monad}
+ [clauses (monad.map @ (function (_ [match then])
+ (do @
+ [then! (recur then)]
+ (wrap [(//runtime.i64//= (//primitive.i64 (.int match))
+ ..peek-cursor)
+ then!])))
+ (#.Cons cons))]
+ (wrap (_.cond clauses ..fail-pm!)))
+
+ (^template [<tag> <format> <type>]
+ (<tag> cons)
+ (do {@ ///////phase.monad}
+ [cases (monad.map @ (function (_ [match then])
+ (:: @ map (|>> [(list (<format> match))]) (recur then)))
+ (#.Cons cons))]
+ (wrap (_.switch ..peek-cursor
+ cases
+ (#.Some ..fail-pm!)))))
+ ([#/////synthesis.F64-Fork //primitive.f64 Frac]
+ [#/////synthesis.Text-Fork //primitive.text Text])
+
+ (#/////synthesis.Then bodyS)
+ (do ///////phase.monad
+ [body! (generate archive bodyS)]
+ (wrap (_.return body!)))
+
+ (^template [<complex> <choice>]
+ (^ (<complex> idx))
+ (///////phase@wrap (<choice> false idx)))
+ ([/////synthesis.side/left ..left-choice]
+ [/////synthesis.side/right ..right-choice])
+
+ (^template [<pm> <getter>]
+ (^ (<pm> lefts))
+ (///////phase@wrap (push-cursor! (<getter> (_.i32 (.int lefts)) ..peek-cursor))))
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^template [<tag> <combinator>]
+ (^ (<tag> leftP rightP))
+ (do ///////phase.monad
+ [left! (recur leftP)
+ right! (recur rightP)]
+ (wrap (<combinator> left! right!))))
+ ([/////synthesis.path/seq _.then]
+ [/////synthesis.path/alt ..alternation]))))))
(def: (pattern-matching generate archive pathP)
(-> Phase Archive Path (Operation Statement))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
index 01312ba83..096993996 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
@@ -24,16 +24,23 @@
(def: #export (scope generate archive [start initsS+ bodyS])
(Generator (Scope Synthesis))
- (do {@ ///////phase.monad}
- [initsO+ (monad.map @ (generate archive) initsS+)
- bodyO (/////generation.with-anchor @scope
- (generate archive bodyS))
- #let [closure (_.function @scope
- (|> initsS+
- list.enumerate
- (list@map (|>> product.left (n.+ start) //case.register)))
- (_.return bodyO))]]
- (wrap (_.apply/* closure initsO+))))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (generate archive bodyS)
+
+ ## true loop
+ _
+ (do {@ ///////phase.monad}
+ [initsO+ (monad.map @ (generate archive) initsS+)
+ bodyO (/////generation.with-anchor @scope
+ (generate archive bodyS))
+ #let [closure (_.function @scope
+ (|> initsS+
+ list.enumerate
+ (list@map (|>> product.left (n.+ start) //case.register)))
+ (_.return bodyO))]]
+ (wrap (_.apply/* closure initsO+)))))
(def: #export (recur generate archive argsS+)
(Generator (List Synthesis))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
index aa9d8f5a5..8fc87bcc2 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -59,19 +59,17 @@
[locals /.locals]
(wrap (|> functionS
(//loop.optimization true locals argsS)
- (maybe@map (: (-> Synthesis Synthesis)
- (function (_ synthesis)
- (case synthesis
- (^ (<| /.loop/scope [start inits]
- /.loop/scope [start' inits']
- output))
+ (maybe@map (: (-> [Nat (List Synthesis) Synthesis] Synthesis)
+ (function (_ [start inits iteration])
+ (case iteration
+ (^ (/.loop/scope [start' inits' output]))
(if (and (n.= start start')
(list.empty? inits'))
(/.loop/scope [start inits output])
- synthesis)
+ (/.loop/scope [start inits iteration]))
_
- synthesis))))
+ (/.loop/scope [start inits iteration])))))
(maybe.default <apply>))))
(wrap <apply>))
@@ -274,10 +272,10 @@
(wrap (if currying?
(/.function/abstraction abstraction)
(case (//loop.optimization false 1 (list) abstraction)
- (#.Some loop-body)
+ (#.Some [startL initsL bodyL])
(/.function/abstraction {#/.environment environment
#/.arity (get@ #/.arity abstraction)
- #/.body loop-body})
+ #/.body (/.loop/scope [startL initsL bodyL])})
#.None
(/.function/abstraction abstraction))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
index ecd1889cb..e2e4e4db5 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
@@ -198,7 +198,7 @@
(maybe@map (|>> [name] #/.Extension))))))
(def: #export (optimization true-loop? offset inits functionS)
- (-> Bit Register (List Synthesis) Abstraction (Maybe Synthesis))
+ (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis]))
(|> (get@ #/.body functionS)
(body-optimization true-loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS))
- (maybe@map (|>> [offset inits] /.loop/scope))))
+ (maybe@map (|>> [offset inits]))))