diff options
author | Eduardo Julian | 2020-10-07 17:00:57 -0400 |
---|---|---|
committer | Eduardo Julian | 2020-10-07 17:00:57 -0400 |
commit | ce7614f00a134cb61b4a6f88cfea33461a7bf478 (patch) | |
tree | fcd6fd7206ceef50db7687c6d4d8b71ff581d41b /stdlib/source/lux | |
parent | de673c2adf9fdf848f8fff977a6cddc036cbfa9e (diff) |
Test imports for circular dependencies.
Diffstat (limited to 'stdlib/source/lux')
-rw-r--r-- | stdlib/source/lux/data/env.lux | 25 | ||||
-rw-r--r-- | stdlib/source/lux/data/identity.lux | 19 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 76 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 183 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/directive.lux | 2 |
5 files changed, 215 insertions, 90 deletions
diff --git a/stdlib/source/lux/data/env.lux b/stdlib/source/lux/data/env.lux deleted file mode 100644 index 7e4265e6a..000000000 --- a/stdlib/source/lux/data/env.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - comonad]]) - -(type: #export (Env e a) - {#env e - #value a}) - -(structure: #export functor (All [e] (Functor (Env e))) - (def: (map f fa) - (update@ #value f fa))) - -(structure: #export comonad (All [e] (CoMonad (Env e))) - (def: &functor ..functor) - - (def: unwrap (get@ #value)) - - (def: (split wa) - (set@ #value wa wa))) - -(def: #export (local change env) - (All [e a] (-> (-> e e) (Env e a) (Env e a))) - (update@ #env change env)) diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux index 412103987..ce0476d8a 100644 --- a/stdlib/source/lux/data/identity.lux +++ b/stdlib/source/lux/data/identity.lux @@ -11,20 +11,27 @@ (type: #export (Identity a) a) -(structure: #export functor (Functor Identity) +(structure: #export functor + (Functor Identity) + (def: map function.identity)) -(structure: #export apply (Apply Identity) +(structure: #export apply + (Apply Identity) + (def: &functor ..functor) - (def: (apply ff fa) - (ff fa))) + (def: (apply ff fa) (ff fa))) -(structure: #export monad (Monad Identity) +(structure: #export monad + (Monad Identity) + (def: &functor ..functor) (def: wrap function.identity) (def: join function.identity)) -(structure: #export comonad (CoMonad Identity) +(structure: #export comonad + (CoMonad Identity) + (def: &functor ..functor) (def: unwrap function.identity) (def: split function.identity)) diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux index e1c19c55d..c46b5bf1f 100644 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -456,7 +456,11 @@ (#try.Failure _) (..bytecode $0 $1 @_ _.ldc-w/string [index])))) -(import: #long java/lang/Float) +(import: #long java/lang/Float + (#static floatToRawIntBits #manual [float] int)) + +(import: #long java/lang/Double + (#static doubleToRawLongBits #manual [double] int)) (template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>] [(def: #export (<name> value) @@ -484,13 +488,42 @@ [+3 _.iconst-3] [+4 _.iconst-4] [+5 _.iconst-5])] - [float java/lang/Float //constant.float //constant/pool.float _.ldc-w/float - (<| (:coerce Frac) host.float-to-double) - ([+0.0 _.fconst-0] - [+1.0 _.fconst-1] - [+2.0 _.fconst-2])] ) +(def: (arbitrary-float value) + (-> java/lang/Float (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.float (//constant.float value)))] + (case (|> index //index.value //unsigned.value //unsigned.u1) + (#try.Success index) + (..bytecode $0 $1 @_ _.ldc [index]) + + (#try.Failure _) + (..bytecode $0 $1 @_ _.ldc-w/float [index])))) + +(def: float-bits + (-> java/lang/Float Int) + (|>> java/lang/Float::floatToRawIntBits + host.int-to-long + (:coerce Int))) + +(def: negative-zero-float-bits + (|> -0.0 host.double-to-float ..float-bits)) + +(def: #export (float value) + (-> java/lang/Float (Bytecode Any)) + (if (i.= ..negative-zero-float-bits + (..float-bits value)) + (..arbitrary-float value) + (case (|> value host.float-to-double (:coerce Frac)) + (^template [<special> <instruction>] + <special> (..bytecode $0 $1 @_ <instruction> [])) + ([+0.0 _.fconst-0] + [+1.0 _.fconst-1] + [+2.0 _.fconst-2]) + + _ (..arbitrary-float value)))) + (template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>] [(def: #export (<name> value) (-> <type> (Bytecode Any)) @@ -507,12 +540,35 @@ (<|) ([+0 _.lconst-0] [+1 _.lconst-1])] - [double Frac //constant.double //constant/pool.double _.ldc2-w/double - (<|) - ([+0.0 _.dconst-0] - [+1.0 _.dconst-1])] ) +(def: (arbitrary-double value) + (-> java/lang/Double (Bytecode Any)) + (do ..monad + [index (..lift (//constant/pool.double (//constant.double value)))] + (..bytecode $0 $2 @_ _.ldc2-w/double [index]))) + +(def: double-bits + (-> java/lang/Double Int) + (|>> java/lang/Double::doubleToRawLongBits + (:coerce Int))) + +(def: negative-zero-double-bits + (..double-bits -0.0)) + +(def: #export (double value) + (-> java/lang/Double (Bytecode Any)) + (if (i.= ..negative-zero-double-bits + (..double-bits value)) + (..arbitrary-double value) + (case value + (^template [<special> <instruction>] + <special> (..bytecode $0 $2 @_ <instruction> [])) + ([+0.0 _.dconst-0] + [+1.0 _.dconst-1]) + + _ (..arbitrary-double value)))) + (exception: #export (invalid-register {id Nat}) (exception.report ["ID" (%.nat id)])) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 2d005d450..d15bec236 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -5,6 +5,7 @@ [abstract ["." monad (#+ Monad do)]] [control + ["." function] ["." try (#+ Try)] ["." exception (#+ exception:)] [concurrency @@ -14,12 +15,13 @@ ["." binary (#+ Binary)] ["." bit] ["." product] + ["." maybe] ["." text ("#@." equivalence) ["%" format (#+ format)]] [collection ["." dictionary (#+ Dictionary)] ["." row (#+ Row) ("#@." fold)] - ["." set] + ["." set (#+ Set)] ["." list ("#@." monoid functor fold)]] [format ["_" binary (#+ Writer)]]] @@ -240,12 +242,94 @@ #///generation.log] row.empty)) + (def: empty + (Set Module) + (set.new text.hash)) + + (type: Mapping + (Dictionary Module (Set Module))) + + (type: Dependence + {#depends-on Mapping + #depended-by Mapping}) + + (def: independence + Dependence + (let [empty (dictionary.new text.hash)] + {#depends-on empty + #depended-by empty})) + + (def: (depend module import dependence) + (-> Module Module Dependence Dependence) + (let [transitive-dependency (: (-> (-> Dependence Mapping) Module (Set Module)) + (function (_ lens module) + (|> dependence + lens + (dictionary.get module) + (maybe.default ..empty)))) + transitive-depends-on (transitive-dependency (get@ #depends-on) import) + transitive-depended-by (transitive-dependency (get@ #depended-by) module) + update-dependence (: (-> [Module (Set Module)] [Module (Set Module)] + (-> Mapping Mapping)) + (function (_ [source forward] [target backward]) + (function (_ mapping) + (let [with-dependence+transitives + (|> mapping + (dictionary.upsert source ..empty (set.add target)) + (dictionary.update source (set.union forward)))] + (list@fold (function (_ previous) + (dictionary.upsert previous ..empty (set.add target))) + with-dependence+transitives + (set.to-list backward))))))] + (|> dependence + (update@ #depends-on + (update-dependence + [module transitive-depends-on] + [import transitive-depended-by])) + (update@ #depended-by + ((function.flip update-dependence) + [module transitive-depends-on] + [import transitive-depended-by]))))) + + (def: (circular-dependency? module import dependence) + (-> Module Module Dependence Bit) + (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) + (function (_ from relationship to) + (let [targets (|> dependence + relationship + (dictionary.get from) + (maybe.default ..empty))] + (set.member? targets to))))] + (or (dependence? import (get@ #depends-on) module) + (dependence? module (get@ #depended-by) import)))) + + (exception: #export (module-cannot-import-itself {module Module}) + (exception.report + ["Module" (%.text module)])) + + (exception: #export (cannot-import-circular-dependency {importer Module} + {importee Module}) + (exception.report + ["Importer" (%.text importer)] + ["importee" (%.text importee)])) + + (def: (verify-dependencies importer importee dependence) + (-> Module Module Dependence (Try Any)) + (cond (text@= importer importee) + (exception.throw ..module-cannot-import-itself [importer]) + + (..circular-dependency? importer importee dependence) + (exception.throw ..cannot-import-circular-dependency [importer importee]) + + ## else + (#try.Success []))) + (with-expansions [<Context> (as-is [Archive <State+>]) <Result> (as-is (Try <Context>)) <Return> (as-is (Promise <Result>)) <Signal> (as-is (Resolver <Result>)) <Pending> (as-is [<Return> <Signal>]) - <Importer> (as-is (-> Module <Return>)) + <Importer> (as-is (-> Module Module <Return>)) <Compiler> (as-is (-> <Importer> archive.ID <Context> Module <Return>))] (def: (parallel initial) (All [<type-vars>] @@ -256,9 +340,11 @@ {<Context> initial} {(Var (Dictionary Module <Pending>)) - (:assume (stm.var (dictionary.new text.hash)))})] + (:assume (stm.var (dictionary.new text.hash)))}) + dependence (: (Var Dependence) + (stm.var ..independence))] (function (_ compile) - (function (import! module) + (function (import! importer module) (do {@ promise.monad} [[return signal] (:share [<type-vars>] {<Context> @@ -269,40 +355,52 @@ (:assume (stm.commit (do {@ stm.monad} - [[archive state] (stm.read current)] - (if (archive.archived? archive module) - (wrap [(promise@wrap (#try.Success [archive state])) + [dependence (if (text@= archive.runtime-module importer) + (stm.read dependence) + (do @ + [[_ dependence] (stm.update (..depend importer module) dependence)] + (wrap dependence)))] + (case (..verify-dependencies importer module dependence) + (#try.Failure error) + (wrap [(promise.resolved (#try.Failure error)) #.None]) + + (#try.Success _) (do @ - [@pending (stm.read pending)] - (case (dictionary.get module @pending) - (#.Some [return signal]) - (wrap [return + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (wrap [(promise@wrap (#try.Success [archive state])) #.None]) - - #.None - (case (if (archive.reserved? archive module) - (do try.monad - [module-id (archive.id module archive)] - (wrap [module-id archive])) - (archive.reserve module archive)) - (#try.Success [module-id archive]) - (do @ - [_ (stm.write [archive state] current) - #let [[return signal] (:share [<type-vars>] - {<Context> - initial} - {<Pending> - (promise.promise [])})] - _ (stm.update (dictionary.put module [return signal]) pending)] + (do @ + [@pending (stm.read pending)] + (case (dictionary.get module @pending) + (#.Some [return signal]) (wrap [return - (#.Some [[archive state] - module-id - signal])])) - - (#try.Failure error) - (wrap [(promise@wrap (#try.Failure error)) - #.None]))))))))}) + #.None]) + + #.None + (case (if (archive.reserved? archive module) + (do try.monad + [module-id (archive.id module archive)] + (wrap [module-id archive])) + (archive.reserve module archive)) + (#try.Success [module-id archive]) + (do @ + [_ (stm.write [archive state] current) + #let [[return signal] (:share [<type-vars>] + {<Context> + initial} + {<Pending> + (promise.promise [])})] + _ (stm.update (dictionary.put module [return signal]) pending)] + (wrap [return + (#.Some [[archive state] + module-id + signal])])) + + (#try.Failure error) + (wrap [(promise@wrap (#try.Failure error)) + #.None]))))))))))}) _ (case signal #.None (wrap []) @@ -363,16 +461,6 @@ try.assume product.left)) - (exception: #export (module-cannot-import-itself {module Module}) - (exception.report - ["Module" (%.text module)])) - - (def: (verify-no-self-import! module dependencies) - (-> Module (List Module) (Try Any)) - (if (list.any? (text@= module) dependencies) - (exception.throw ..module-cannot-import-itself [module]) - (#try.Success []))) - (def: #export (compile import static expander platform compilation context) (All [<type-vars>] (-> Import Static Expander <Platform> Compilation <Context> <Return>)) @@ -413,9 +501,8 @@ (#.Cons _) (do @ - [_ (:: promise.monad wrap (verify-no-self-import! module new-dependencies)) - archive,document+ (|> new-dependencies - (list@map import!) + [archive,document+ (|> new-dependencies + (list@map (import! module)) (monad.seq ..monad)) #let [archive (|> archive,document+ (list@map product.left) @@ -452,5 +539,5 @@ (do @ [_ (ioW.freeze (get@ #&file-system platform) static archive)] (promise@wrap (#try.Failure error))))))))))] - (compiler compilation-module))) + (compiler archive.runtime-module compilation-module))) )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux index 8a5e0172a..11dc98bef 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/directive.lux @@ -73,7 +73,7 @@ ) (def: #export (set-current-module module) - (All [anchor expression directive output] + (All [anchor expression directive] (-> Module (Operation anchor expression directive Any))) (do phase.monad [_ (..lift-analysis |