From fb7f85d1095cb9ba6a402f18e701a4b14b7657dc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Dec 2019 02:53:25 -0400 Subject: Re-located generation infrastructure. --- .../lux/tool/compiler/analysis/evaluation.lux | 4 +- stdlib/source/lux/tool/compiler/default/init.lux | 38 +-- .../source/lux/tool/compiler/default/platform.lux | 30 +-- stdlib/source/lux/tool/compiler/directive.lux | 2 +- stdlib/source/lux/tool/compiler/generation.lux | 298 +++++++++++++++++++++ .../compiler/phase/extension/directive/lux.lux | 32 +-- .../source/lux/tool/compiler/phase/generation.lux | 298 --------------------- .../tool/compiler/phase/generation/extension.lux | 14 +- .../tool/compiler/phase/generation/jvm/case.lux | 4 +- .../phase/generation/jvm/extension/host.lux | 11 +- .../compiler/phase/generation/jvm/function.lux | 6 +- .../tool/compiler/phase/generation/jvm/loop.lux | 4 +- .../compiler/phase/generation/jvm/packager.lux | 18 +- .../compiler/phase/generation/jvm/reference.lux | 4 +- .../tool/compiler/phase/generation/jvm/runtime.lux | 32 +-- stdlib/source/program/compositor.lux | 4 +- 16 files changed, 399 insertions(+), 400 deletions(-) create mode 100644 stdlib/source/lux/tool/compiler/generation.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/tool/compiler/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/analysis/evaluation.lux index 5b0efc987..08a57bf20 100644 --- a/stdlib/source/lux/tool/compiler/analysis/evaluation.lux +++ b/stdlib/source/lux/tool/compiler/analysis/evaluation.lux @@ -14,9 +14,9 @@ [".P" analysis ["." type]] [".P" synthesis] - ["." generation] [// - ["." synthesis]]]]]) + ["." synthesis] + ["." generation]]]]]) (type: #export Eval (-> Nat Type Code (Operation Any))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index e31cb7107..dc94f5507 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -23,11 +23,11 @@ ["#/." evaluation]] ["#." synthesis] ["#." directive (#+ Requirements)] + ["#." generation] ["#." phase [".P" analysis ["." module]] [".P" synthesis] - ["." generation] [".P" directive] ["." extension (#+ Extender) [".E" analysis] @@ -52,15 +52,15 @@ (-> Text Expander ///analysis.Bundle - (generation.Host expression directive) - (generation.Phase anchor expression directive) - (generation.Bundle anchor expression directive) + (///generation.Host expression directive) + (///generation.Phase anchor expression directive) + (///generation.Bundle anchor expression directive) (///directive.Bundle anchor expression directive) (-> expression directive) Extender (///directive.State+ anchor expression directive))) (let [synthesis-state [synthesisE.bundle ///synthesis.init] - generation-state [generation-bundle (generation.state host)] + generation-state [generation-bundle (///generation.state host)] eval (///analysis/evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval host-analysis) (///analysis.state (..info target) host)]] @@ -104,7 +104,7 @@ (-> (List Module) Nat ///.Input (All [anchor expression directive] (///directive.Operation anchor expression directive - [Source (generation.Buffer directive)]))) + [Source (///generation.Buffer directive)]))) (///directive.lift-analysis (do ///phase.monad [#let [module (get@ #///.module input)] @@ -113,7 +113,7 @@ _ (monad.map @ module.import dependencies) #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))] _ (///analysis.set-source-code source)] - (wrap [source generation.empty-buffer])))) + (wrap [source ///generation.empty-buffer])))) (def: (end module) (-> Module (Operation Any)) @@ -121,28 +121,28 @@ [_ (///directive.lift-analysis (module.set-compiled module))] (///directive.lift-generation - (generation.save-buffer! module)))) + (///generation.save-buffer! module)))) ## TODO: Inline ASAP (def: (get-current-buffer old-buffer) (All [directive] - (-> (generation.Buffer directive) + (-> (///generation.Buffer directive) (All [anchor expression] (///directive.Operation anchor expression directive - (generation.Buffer directive))))) + (///generation.Buffer directive))))) (///directive.lift-generation - generation.buffer)) + ///generation.buffer)) ## TODO: Inline ASAP (def: (process-directive expander pre-buffer code) (All [directive] - (-> Expander (generation.Buffer directive) Code + (-> Expander (///generation.Buffer directive) Code (All [anchor expression] (///directive.Operation anchor expression directive - [Requirements (generation.Buffer directive)])))) + [Requirements (///generation.Buffer directive)])))) (do ///phase.monad [_ (///directive.lift-generation - (generation.set-buffer pre-buffer)) + (///generation.set-buffer pre-buffer)) requirements (let [execute! (directiveP.phase expander)] (execute! code)) post-buffer (..get-current-buffer pre-buffer)] @@ -150,10 +150,10 @@ (def: (iteration expander reader source pre-buffer) (All [directive] - (-> Expander Reader Source (generation.Buffer directive) + (-> Expander Reader Source (///generation.Buffer directive) (All [anchor expression] (///directive.Operation anchor expression directive - [Source Requirements (generation.Buffer directive)])))) + [Source Requirements (///generation.Buffer directive)])))) (do ///phase.monad [[source code] (///directive.lift-analysis (..read source reader)) @@ -162,10 +162,10 @@ (def: (iterate expander module source pre-buffer aliases) (All [directive] - (-> Expander Module Source (generation.Buffer directive) Aliases + (-> Expander Module Source (///generation.Buffer directive) Aliases (All [anchor expression] (///directive.Operation anchor expression directive - (Maybe [Source Requirements (generation.Buffer directive)]))))) + (Maybe [Source Requirements (///generation.Buffer directive)]))))) (do ///phase.monad [reader (///directive.lift-analysis (..reader module aliases source))] @@ -239,7 +239,7 @@ extension.lift macro.current-module) _ (///directive.lift-generation - (generation.set-buffer buffer)) + (///generation.set-buffer buffer)) _ (monad.map @ execute! (get@ #///directive.referrals requirements)) buffer (..get-current-buffer buffer)] (..iterate expander module source buffer (..module-aliases analysis-module))))))})]) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 23b1c5b6c..3c26cc232 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -22,11 +22,11 @@ ["/#" // ["#." analysis [macro (#+ Expander)]] + ["#." generation (#+ Buffer)] ["#." directive] ["#." phase ## TODO: Get rid of this import ASAP ["." extension (#+ Extender)] - ["." generation (#+ Buffer)] [analysis ["." module]]] [meta @@ -40,9 +40,9 @@ (type: #export (Platform anchor expression directive) {#&file-system (file.System Promise) - #host (generation.Host expression directive) - #phase (generation.Phase anchor expression directive) - #runtime (generation.Operation anchor expression directive Any)}) + #host (///generation.Host expression directive) + #phase (///generation.Phase anchor expression directive) + #runtime (///generation.Operation anchor expression directive Any)}) ## (def: (write-module target-dir file-name module-name module outputs) ## (-> File Text Text Module Outputs (Process Any)) @@ -56,37 +56,37 @@ (with-expansions [ (as-is [anchor expression directive]) (as-is (Platform anchor expression directive)) (as-is (///directive.State+ anchor expression directive)) - (as-is (generation.Bundle anchor expression directive))] + (as-is (///generation.Bundle anchor expression directive))] (def: pause-context (All - (-> generation.Context)) - (get@ [#extension.state #///directive.generation #///directive.state #extension.state #generation.context])) + (-> ///generation.Context)) + (get@ [#extension.state #///directive.generation #///directive.state #extension.state #///generation.context])) (def: (resume-context context state) (All - (-> generation.Context )) - (set@ [#extension.state #///directive.generation #///directive.state #extension.state #generation.context] + (-> ///generation.Context )) + (set@ [#extension.state #///directive.generation #///directive.state #extension.state #///generation.context] context state)) ## TODO: Inline ASAP (def: initialize-buffer! (All - (generation.Operation anchor expression directive Any)) - (generation.set-buffer generation.empty-buffer)) + (///generation.Operation anchor expression directive Any)) + (///generation.set-buffer ///generation.empty-buffer)) ## TODO: Inline ASAP (def: compile-runtime! (All - (-> (generation.Operation anchor expression directive Any))) + (-> (///generation.Operation anchor expression directive Any))) (get@ #runtime)) ## TODO: Inline ASAP (def: save-runtime-buffer! (All - (generation.Operation anchor expression directive (Buffer directive))) - (generation.save-buffer! "")) + (///generation.Operation anchor expression directive (Buffer directive))) + (///generation.save-buffer! "")) (def: #export (initialize target expander host-analysis platform generation-bundle host-directive-bundle program extender) (All @@ -171,7 +171,7 @@ ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) ] (loop [archive archive - state (..resume-context (generation.fresh-context module) state) + state (..resume-context (///generation.fresh-context module) state) compilation (compiler (:coerce ///.Input input))] (do @ [#let [dependencies (get@ #///.dependencies compilation) diff --git a/stdlib/source/lux/tool/compiler/directive.lux b/stdlib/source/lux/tool/compiler/directive.lux index b307213c2..31edabddb 100644 --- a/stdlib/source/lux/tool/compiler/directive.lux +++ b/stdlib/source/lux/tool/compiler/directive.lux @@ -9,8 +9,8 @@ [descriptor (#+ Module)]]] ["." analysis] ["." synthesis] + ["." generation] ["." phase - ["." generation] ["." extension]]]) (type: #export (Component state phase) diff --git a/stdlib/source/lux/tool/compiler/generation.lux b/stdlib/source/lux/tool/compiler/generation.lux new file mode 100644 index 000000000..e29036dd9 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/generation.lux @@ -0,0 +1,298 @@ +(.module: + [lux (#- Module) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." name ("#@." equivalence)] + ["." text + ["%" format (#+ format)]] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)] + ["." list ("#@." functor)]]]] + [// + ["." phase + ["." extension]] + [synthesis (#+ Synthesis)] + [meta + [archive + [descriptor (#+ Module)]]]]) + +(type: #export Registry + (Dictionary Name Text)) + +(exception: #export (cannot-interpret {error Text}) + (exception.report + ["Error" error])) + +(exception: #export (unknown-lux-name {name Name} {registry Registry}) + (exception.report + ["Name" (%.name name)] + ["Registry" (|> registry + dictionary.keys + (list.sort (:: name.order <)) + (list@map %.name) + (text.join-with text.new-line))])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (exception.report + ["Lux Name" (%.name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(template [] + [(exception: #export ( {name Name}) + (exception.report + ["Output" (%.name name)]))] + + [cannot-overwrite-output] + [no-buffer-for-saving-code] + ) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(signature: #export (Host expression directive) + (: (-> Text expression (Try Any)) + evaluate!) + (: (-> Text directive (Try Any)) + execute!) + (: (-> Name expression (Try [Text Any directive])) + define!)) + +(type: #export (Buffer directive) (Row [Name directive])) +(type: #export (Output directive) (Row [Module (Buffer directive)])) + +(type: #export (State anchor expression directive) + {#context Context + #anchor (Maybe anchor) + #host (Host expression directive) + #buffer (Maybe (Buffer directive)) + #output (Output directive) + #counter Nat + #name-cache Registry}) + +(template [ ] + [(type: #export ( anchor expression directive) + ( (State anchor expression directive) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (fresh-context scope-name) + (-> Text Context) + {#scope-name scope-name + #inner-functions 0}) + +(def: #export (state host) + (All [anchor expression directive] + (-> (Host expression directive) + (..State anchor expression directive))) + {#context (..fresh-context "") + #anchor #.None + #host host + #buffer #.None + #output row.empty + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-specific-context specific-scope expr) + (All [anchor expression directive output] + (-> Text + (Operation anchor expression directive output) + (Operation anchor expression directive output))) + (function (_ [bundle state]) + (let [old (get@ #context state)] + (case (expr [bundle (set@ #context (..fresh-context specific-scope) state)]) + (#try.Success [[bundle' state'] + output]) + (#try.Success [[bundle' (set@ #context old state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export (with-context expr) + (All [anchor expression directive output] + (-> (Operation anchor expression directive output) + (Operation anchor expression directive [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "$c" (%.nat old-inner))] + (case (expr [bundle (set@ #context (..fresh-context new-scope) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ #context {#scope-name old-scope + #inner-functions (inc old-inner)} + state')] + [new-scope output]]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export context + (All [anchor expression directive] + (Operation anchor expression directive Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(def: #export empty-buffer Buffer row.empty) + +(template [ + + ] + [(exception: #export ) + + (def: #export + (All [anchor expression directive output] ) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ (#.Some ) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ (get@ state) state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + + (def: #export + (All [anchor expression directive] + (Operation anchor expression directive )) + (function (_ (^@ stateE [bundle state])) + (case (get@ state) + (#.Some output) + (#try.Success [stateE output]) + + #.None + (exception.throw [])))) + + (def: #export ( value) + (All [anchor expression directive] + (-> (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (set@ (#.Some value) state)] + []])))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation anchor expression directive output) + (Operation anchor expression directive output)) + anchor + set-anchor anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation anchor expression directive output) + (Operation anchor expression directive output)) + ..empty-buffer + set-buffer buffer (Buffer directive) no-active-buffer] + ) + +(def: #export output + (All [anchor expression directive] + (Operation anchor expression directive (Output directive))) + (extension.read (get@ #output))) + +(def: #export next + (All [anchor expression directive] + (Operation anchor expression directive Nat)) + (do phase.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(def: #export (gensym prefix) + (All [anchor expression directive] + (-> Text (Operation anchor expression directive Text))) + (:: phase.monad map (|>> %.nat (format prefix)) ..next)) + +(template [ ] + [(def: #export ( label code) + (All [anchor expression directive] + (-> Text (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) label code) + (#try.Success output) + (#try.Success [state+ output]) + + (#try.Failure error) + (exception.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! directive] + ) + +(def: #export (define! name code) + (All [anchor expression directive] + (-> Name expression (Operation anchor expression directive [Text Any directive]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#try.Success output) + (#try.Success [stateE output]) + + (#try.Failure error) + (exception.throw cannot-interpret error)))) + +(def: #export (save! execute? name code) + (All [anchor expression directive] + (-> Bit Name directive (Operation anchor expression directive Any))) + (do phase.monad + [label (..gensym "save") + _ (if execute? + (execute! label code) + (wrap [])) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (name@= name)) buffer) + (phase.throw ..cannot-overwrite-output name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (phase.throw no-buffer-for-saving-code name)))) + +(def: #export (save-buffer! target) + (All [anchor expression directive] + (-> Module (Operation anchor expression directive (Buffer directive)))) + (do phase.monad + [buffer ..buffer + _ (extension.update (update@ #output (row.add [target buffer])))] + (wrap buffer))) + +(def: #export (remember lux-name) + (All [anchor expression directive] + (-> Name (Operation anchor expression directive Text))) + (function (_ (^@ stateE [_ state])) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + (#.Some host-name) + (#try.Success [stateE host-name]) + + #.None + (exception.throw unknown-lux-name [lux-name cache]))))) + +(def: #export (learn lux-name host-name) + (All [anchor expression directive] + (-> Name Text (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + #.None + (#try.Success [[bundle + (update@ #name-cache + (dictionary.put lux-name host-name) + state)] + []]) + + (#.Some old-host-name) + (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux index faf7a0c13..084bc8080 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux @@ -23,16 +23,16 @@ ["#." bundle] ["#." analysis] ["#/" // - ["#." generation] [analysis ["." module] [".A" type]] ["#/" // #_ - ["#." synthesis (#+ Synthesis)] - ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)] ["#." analysis [macro (#+ Expander)] - ["#/." evaluation]]]]]) + ["#/." evaluation]] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)]]]]) (def: #export (custom [syntax handler]) (All [anchor expression directive s] @@ -53,15 +53,15 @@ ## TODO: Inline "evaluate!'" into "evaluate!" ASAP (def: (evaluate!' generate code//type codeS) (All [anchor expression directive] - (-> (////generation.Phase anchor expression directive) + (-> (/////generation.Phase anchor expression directive) Type Synthesis (Operation anchor expression directive [Type expression Any]))) (/////directive.lift-generation (do ////.monad [codeT (generate codeS) - id ////generation.next - codeV (////generation.evaluate! (format "evaluate" (%.nat id)) codeT)] + id /////generation.next + codeV (/////generation.evaluate! (format "evaluate" (%.nat id)) codeT)] (wrap [code//type codeT codeV])))) (def: #export (evaluate! type codeC) @@ -84,7 +84,7 @@ ## TODO: Inline "definition'" into "definition" ASAP (def: (definition' generate name code//type codeS) (All [anchor expression directive] - (-> (////generation.Phase anchor expression directive) + (-> (/////generation.Phase anchor expression directive) Name Type Synthesis @@ -92,8 +92,8 @@ (/////directive.lift-generation (do ////.monad [codeT (generate codeS) - [target-name value directive] (////generation.define! name codeT) - _ (////generation.save! false name directive)] + [target-name value directive] (/////generation.define! name codeT) + _ (/////generation.save! false name directive)] (wrap [code//type codeT target-name value])))) (def: (definition name expected codeC) @@ -156,7 +156,7 @@ (module.define short-name (#.Right [exported? type (:coerce Code annotations) value]))) #let [_ (log! (format "Definition " (%.name full-name)))] _ (/////directive.lift-generation - (////generation.learn full-name valueN)) + (/////generation.learn full-name valueN)) _ (..refresh expander host-analysis)] (wrap /////directive.no-requirements)) @@ -181,7 +181,7 @@ (module.declare-tags tags exported? (:coerce Type value)))) #let [_ (log! (format "Definition " (%.name full-name)))] _ (/////directive.lift-generation - (////generation.learn full-name valueN)) + (/////generation.learn full-name valueN)) _ (..refresh expander host-analysis)] (wrap /////directive.no-requirements)))])) @@ -272,7 +272,7 @@ ["Analysis" def::analysis /////analysis.Handler /////directive.lift-analysis] ["Synthesis" def::synthesis /////synthesis.Handler /////directive.lift-synthesis] - ["Generation" def::generation (////generation.Handler anchor expression directive) /////directive.lift-generation] + ["Generation" def::generation (/////generation.Handler anchor expression directive) /////directive.lift-generation] ["Directive" def::directive (/////directive.Handler anchor expression directive) (<|)] ) @@ -296,13 +296,13 @@ (def: (define-program generate program programS) (All [anchor expression directive output] - (-> (////generation.Phase anchor expression directive) + (-> (/////generation.Phase anchor expression directive) (-> expression directive) Synthesis - (////generation.Operation anchor expression directive Any))) + (/////generation.Operation anchor expression directive Any))) (do ////.monad [programG (generate programS)] - (////generation.save! false ["" ""] (program programG)))) + (/////generation.save! false ["" ""] (program programG)))) (def: (def::program program) (All [anchor expression directive] diff --git a/stdlib/source/lux/tool/compiler/phase/generation.lux b/stdlib/source/lux/tool/compiler/phase/generation.lux deleted file mode 100644 index ca2d76965..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation.lux +++ /dev/null @@ -1,298 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." name ("#@." equivalence)] - ["." text - ["%" format (#+ format)]] - [collection - ["." row (#+ Row)] - ["." dictionary (#+ Dictionary)] - ["." list ("#@." functor)]]]] - ["." // - ["." extension] - [// - [synthesis (#+ Synthesis)] - [meta - [archive - [descriptor (#+ Module)]]]]]) - -(type: #export Registry - (Dictionary Name Text)) - -(exception: #export (cannot-interpret {error Text}) - (exception.report - ["Error" error])) - -(exception: #export (unknown-lux-name {name Name} {registry Registry}) - (exception.report - ["Name" (%.name name)] - ["Registry" (|> registry - dictionary.keys - (list.sort (:: name.order <)) - (list@map %.name) - (text.join-with text.new-line))])) - -(exception: #export (cannot-overwrite-lux-name {lux-name Name} - {old-host-name Text} - {new-host-name Text}) - (exception.report - ["Lux Name" (%.name lux-name)] - ["Old Host Name" old-host-name] - ["New Host Name" new-host-name])) - -(template [] - [(exception: #export ( {name Name}) - (exception.report - ["Output" (%.name name)]))] - - [cannot-overwrite-output] - [no-buffer-for-saving-code] - ) - -(type: #export Context - {#scope-name Text - #inner-functions Nat}) - -(signature: #export (Host expression directive) - (: (-> Text expression (Try Any)) - evaluate!) - (: (-> Text directive (Try Any)) - execute!) - (: (-> Name expression (Try [Text Any directive])) - define!)) - -(type: #export (Buffer directive) (Row [Name directive])) -(type: #export (Output directive) (Row [Module (Buffer directive)])) - -(type: #export (State anchor expression directive) - {#context Context - #anchor (Maybe anchor) - #host (Host expression directive) - #buffer (Maybe (Buffer directive)) - #output (Output directive) - #counter Nat - #name-cache Registry}) - -(template [ ] - [(type: #export ( anchor expression directive) - ( (State anchor expression directive) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (fresh-context scope-name) - (-> Text Context) - {#scope-name scope-name - #inner-functions 0}) - -(def: #export (state host) - (All [anchor expression directive] - (-> (Host expression directive) - (..State anchor expression directive))) - {#context (..fresh-context "") - #anchor #.None - #host host - #buffer #.None - #output row.empty - #counter 0 - #name-cache (dictionary.new name.hash)}) - -(def: #export (with-specific-context specific-scope expr) - (All [anchor expression directive output] - (-> Text - (Operation anchor expression directive output) - (Operation anchor expression directive output))) - (function (_ [bundle state]) - (let [old (get@ #context state)] - (case (expr [bundle (set@ #context (..fresh-context specific-scope) state)]) - (#try.Success [[bundle' state'] - output]) - (#try.Success [[bundle' (set@ #context old state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export (with-context expr) - (All [anchor expression directive output] - (-> (Operation anchor expression directive output) - (Operation anchor expression directive [Text output]))) - (function (_ [bundle state]) - (let [[old-scope old-inner] (get@ #context state) - new-scope (format old-scope "$c" (%.nat old-inner))] - (case (expr [bundle (set@ #context (..fresh-context new-scope) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #context {#scope-name old-scope - #inner-functions (inc old-inner)} - state')] - [new-scope output]]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export context - (All [anchor expression directive] - (Operation anchor expression directive Text)) - (extension.read (|>> (get@ #context) - (get@ #scope-name)))) - -(def: #export empty-buffer Buffer row.empty) - -(template [ - - ] - [(exception: #export ) - - (def: #export - (All [anchor expression directive output] ) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ (#.Some ) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ (get@ state) state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - - (def: #export - (All [anchor expression directive] - (Operation anchor expression directive )) - (function (_ (^@ stateE [bundle state])) - (case (get@ state) - (#.Some output) - (#try.Success [stateE output]) - - #.None - (exception.throw [])))) - - (def: #export ( value) - (All [anchor expression directive] - (-> (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ (#.Some value) state)] - []])))] - - [#anchor - (with-anchor anchor) - (-> anchor (Operation anchor expression directive output) - (Operation anchor expression directive output)) - anchor - set-anchor anchor anchor no-anchor] - - [#buffer - with-buffer - (-> (Operation anchor expression directive output) - (Operation anchor expression directive output)) - ..empty-buffer - set-buffer buffer (Buffer directive) no-active-buffer] - ) - -(def: #export output - (All [anchor expression directive] - (Operation anchor expression directive (Output directive))) - (extension.read (get@ #output))) - -(def: #export next - (All [anchor expression directive] - (Operation anchor expression directive Nat)) - (do //.monad - [count (extension.read (get@ #counter)) - _ (extension.update (update@ #counter inc))] - (wrap count))) - -(def: #export (gensym prefix) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive Text))) - (:: //.monad map (|>> %.nat (format prefix)) ..next)) - -(template [ ] - [(def: #export ( label code) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (:: (get@ #host state) label code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw cannot-interpret error))))] - - [evaluate! expression] - [execute! directive] - ) - -(def: #export (define! name code) - (All [anchor expression directive] - (-> Name expression (Operation anchor expression directive [Text Any directive]))) - (function (_ (^@ stateE [bundle state])) - (case (:: (get@ #host state) define! name code) - (#try.Success output) - (#try.Success [stateE output]) - - (#try.Failure error) - (exception.throw cannot-interpret error)))) - -(def: #export (save! execute? name code) - (All [anchor expression directive] - (-> Bit Name directive (Operation anchor expression directive Any))) - (do //.monad - [label (..gensym "save") - _ (if execute? - (execute! label code) - (wrap [])) - ?buffer (extension.read (get@ #buffer))] - (case ?buffer - (#.Some buffer) - (if (row.any? (|>> product.left (name@= name)) buffer) - (//.throw ..cannot-overwrite-output name) - (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) - - #.None - (//.throw no-buffer-for-saving-code name)))) - -(def: #export (save-buffer! target) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive (Buffer directive)))) - (do //.monad - [buffer ..buffer - _ (extension.update (update@ #output (row.add [target buffer])))] - (wrap buffer))) - -(def: #export (remember lux-name) - (All [anchor expression directive] - (-> Name (Operation anchor expression directive Text))) - (function (_ (^@ stateE [_ state])) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - (#.Some host-name) - (#try.Success [stateE host-name]) - - #.None - (exception.throw unknown-lux-name [lux-name cache]))))) - -(def: #export (learn lux-name host-name) - (All [anchor expression directive] - (-> Name Text (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - #.None - (#try.Success [[bundle - (update@ #name-cache - (dictionary.put lux-name host-name) - state)] - []]) - - (#.Some old-host-name) - (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/extension.lux index 91e1b661c..d0de3e920 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/extension.lux @@ -11,11 +11,11 @@ ["." macro (#+ with-gensyms) ["." code] [syntax (#+ syntax:)]]] - ["." // - ["#/" // - ["#." extension] - [// - [synthesis (#+ Synthesis)]]]]) + ["." /// + ["#." extension] + [// + [synthesis (#+ Synthesis)] + ["." generation]]]) (syntax: (Vector {size s.nat} elemT) (wrap (list (` [(~+ (list.repeat size elemT))])))) @@ -32,7 +32,7 @@ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) (All [(~ g!anchor) (~ g!expression) (~ g!directive)] - (-> ((~ type) (~ g!expression)) (//.Handler (~ g!anchor) (~ g!expression) (~ g!directive)))) + (-> ((~ type) (~ g!expression)) (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive)))) (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) (case (~ g!inputs) (^ (list (~+ g!input+))) @@ -53,7 +53,7 @@ (def: #export (variadic extension) (All [anchor expression directive] - (-> (Variadic expression) (//.Handler anchor expression directive))) + (-> (Variadic expression) (generation.Handler anchor expression directive))) (function (_ extension-name) (function (_ phase inputsS) (do ///.monad diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux index cdb84ad6a..7f33f383b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux @@ -20,8 +20,8 @@ [//// [reference (#+ Register)] ["." synthesis (#+ Path Synthesis)] - ["." phase ("operation@." monad) - ["." generation]]]]) + ["." generation] + ["." phase ("operation@." monad)]]]) (def: equals-name "equals") diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux index 7b14d2c07..84af963d2 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux @@ -49,7 +49,7 @@ [variable ["." foreign]]]] ["//#" /// - ["." generation + [generation [extension (#+ Nullary Unary Binary Trinary Variadic nullary unary binary trinary variadic)]] [extension @@ -57,9 +57,10 @@ [analysis ["/" jvm]]] ["/#" // - [analysis (#+ Environment)] ["#." reference (#+ Variable)] - ["#." synthesis (#+ Synthesis Path %synthesis)]]]]]) + [analysis (#+ Environment)] + ["#." synthesis (#+ Synthesis Path %synthesis)] + ["#." generation]]]]]) (template [ <0> <1>] [(def: @@ -1032,7 +1033,7 @@ self-name arguments returnT exceptionsT bodyS]) (do @ - [bodyG (generation.with-specific-context class-name + [bodyG (//////generation.with-specific-context class-name (generate bodyS))] (wrap (method.method ($_ modifier@compose method.public @@ -1059,7 +1060,7 @@ (list& (..with-anonymous-init class total-environment super-class inputsTI) method-definitions) (row.row))) - _ (generation.save! true ["" class-name] [class-name bytecode])] + _ (//////generation.save! true ["" class-name] [class-name bytecode])] (anonymous-instance class total-environment)))])) (def: bundle::class diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux index c5b18f6b3..8e7d51475 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux @@ -44,12 +44,12 @@ ["/#" // #_ ["#." runtime (#+ Operation Phase)] [//// + ["." arity (#+ Arity)] [reference (#+ Register)] [analysis (#+ Environment)] [synthesis (#+ Synthesis Abstraction Apply)] - ["." arity (#+ Arity)] - ["." phase - ["." generation]]]]]) + ["." generation] + ["." phase]]]]) (def: #export (with @begin class environment arity body) (-> Label External Environment Arity (Bytecode Any) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux index f27dbc269..00ceb8ca4 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux @@ -19,8 +19,8 @@ [//// [reference (#+ Register)] ["." synthesis (#+ Path Synthesis)] - ["." phase - ["." generation]]]]) + ["." generation] + ["." phase]]]) (def: (invariant? register changeS) (-> Register Synthesis Bit) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux index 9400adf1a..983ac3d1a 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux @@ -12,16 +12,14 @@ [target [jvm [encoding - ["." name (#+ External)]]]] - [tool - [compiler - [phase - [generation (#+ Buffer Output) - [jvm - [runtime (#+ Definition)]]]] - [meta - [archive - [descriptor (#+ Module)]]]]]]) + ["." name (#+ External)]]]]] + [// + [runtime (#+ Definition)] + [//// + [generation (#+ Buffer Output)] + [meta + [archive + [descriptor (#+ Module)]]]]]) (import: #long java/lang/Object) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux index 13f6bb846..59115f815 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux @@ -16,9 +16,9 @@ ["#." value] ["#." type] ["//#" /// ("operation@." monad) - ["." generation] [// - ["." reference (#+ Register Variable)]]]]) + ["." reference (#+ Register Variable)] + ["." generation]]]]) (def: #export this (Bytecode Any) 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 5968ed6c8..bd9cc1850 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -41,12 +41,12 @@ [variable [partial ["#/." count]]]]] - ["/#" // - ["/#" // - [// - [arity (#+ Arity)] - [reference (#+ Register)] - ["." synthesis]]]]]) + ["//#" /// + [// + [arity (#+ Arity)] + [reference (#+ Register)] + ["." synthesis] + ["." generation]]]]) (type: #export Byte-Code Binary) @@ -58,17 +58,17 @@ [(type: #export ( Anchor (Bytecode Any) Definition))] - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] + [Operation generation.Operation] + [Phase generation.Phase] + [Handler generation.Handler] + [Bundle generation.Bundle] ) (type: #export (Generator i) (-> Phase i (Operation (Bytecode Any)))) (type: #export Host - (///.Host (Bytecode Any) Definition)) + (generation.Host (Bytecode Any) Definition)) (def: #export class (type.class "LuxRuntime" (list))) @@ -513,8 +513,8 @@ ..try::method)) (row.row)))] (do ////.monad - [_ (///.execute! class [class bytecode])] - (///.save! .false ["" class] [class bytecode])))) + [_ (generation.execute! class [class bytecode])] + (generation.save! .false ["" class] [class bytecode])))) (def: generate-function (Operation Any) @@ -569,8 +569,8 @@ (list& ::method apply::method+) (row.row)))] (do ////.monad - [_ (///.execute! class [class bytecode])] - (///.save! .false ["" class] [class bytecode])))) + [_ (generation.execute! class [class bytecode])] + (generation.save! .false ["" class] [class bytecode])))) (def: #export generate (Operation Any) @@ -584,4 +584,4 @@ ## This shift is done to avoid the possibility of forged labels ## to be in the range of the labels that are generated automatically ## during the evaluation of Bytecode expressions. - (:: ////.monad map (i64.left-shift shift) ///.next))) + (:: ////.monad map (i64.left-shift shift) generation.next))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 117e90ac2..8324df002 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -30,10 +30,10 @@ [compiler ["." analysis [macro (#+ Expander)]] + ["." generation] ["." directive] ["." phase - [extension (#+ Extender)] - ["." generation]] + [extension (#+ Extender)]] [default ["." platform (#+ Platform)] ["." syntax]] -- cgit v1.2.3