diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 10 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 3 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 17 | ||||
| -rw-r--r-- | src/lux/optimizer.clj | 282 |
4 files changed, 135 insertions, 177 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index cf2e4bab7..73d89e036 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -173,9 +173,8 @@ (&&lux/analyse-program analyse optimize compile-program ?args ?body))) ;; else - (&/with-analysis-meta cursor exo-type - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters))) (&/$IntS idx) (&/with-analysis-meta cursor exo-type @@ -186,9 +185,8 @@ (analyse-variant+ analyse exo-type ?ident parameters)) _ - (&/with-analysis-meta cursor exo-type - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters))) _ (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index aa2f27a68..6e36967e1 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -57,7 +57,8 @@ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-1 [analyse exo-type elem] - (cap-1 (analyse exo-type elem))) + (&/with-expected-type exo-type + (cap-1 (analyse exo-type elem)))) (defn analyse-1+ [analyse ?token] (&type/with-var diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 1a3634f8f..0bfa647e5 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -399,10 +399,12 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) _ - (do-analyse-apply analyse exo-type =fn ?args))) + (&/with-analysis-meta cursor exo-type + (do-analyse-apply analyse exo-type =fn ?args)))) _ - (do-analyse-apply analyse exo-type =fn ?args)) + (&/with-analysis-meta cursor exo-type + (do-analyse-apply analyse exo-type =fn ?args))) )) (defn analyse-case [analyse exo-type ?value ?branches] @@ -544,7 +546,7 @@ (return (&/|list output)))) (defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] - (|do [;; _ &/ensure-statement + (|do [_ &/ensure-statement module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? @@ -560,7 +562,7 @@ ))) (defn analyse-import [analyse compile-module path] - (|do [;; _ &/ensure-statement + (|do [_ &/ensure-statement module-name &/get-module-name _ (if (= module-name path) (fail (str "[Analyser Error] Module can't import itself: " path)) @@ -576,7 +578,7 @@ (return &/$Nil))))) (defn analyse-alias [analyse ex-alias ex-module] - (|do [;; _ &/ensure-statement + (|do [_ &/ensure-statement module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] (return &/$Nil))) @@ -591,7 +593,8 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value) + =value (&/with-expected-type ==type + (&&/analyse-1 analyse ==type ?value)) _cursor &/cursor ;; =value (&&/analyse-1 analyse ==type ?value) ;; :let [_ (prn 0 (&/adt->text =value)) @@ -617,7 +620,7 @@ (let [input-type (&/$AppT &type/List &type/Text) output-type (&/$AppT &type/IO &/$UnitT)] (defn analyse-program [analyse optimize compile-program ?args ?body] - (|do [;; _ &/ensure-statement + (|do [_ &/ensure-statement =body (&/with-scope "" (&&env/with-local ?args input-type (&&/analyse-1 analyse output-type ?body))) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 09f23886e..6adfca501 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -57,120 +57,75 @@ (&/$Cons _module (&/$Cons _def (&/$Cons _level-to-remove _levels-to-keep))) (&/$Cons _module (&/$Cons _def _levels-to-keep)))) -(defn ^:private de-meta [body] - "(-> Optimized Optimized)" - (|case body - [meta ($variant idx is-last? value)] - ($variant idx is-last? (de-meta value)) - - [meta ($tuple elems)] - ($tuple (&/|map de-meta elems)) - - [meta ($apply func args)] - ($apply (de-meta func) - (&/|map de-meta args)) - - [meta ($case value branches)] - ($case (de-meta value) - (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (de-meta _body)]))) - branches)) - - [meta ($function arity scope captured body*)] - ($function arity - scope - (&/|map (fn [capture] - (|let [[_name _captured] capture] - (&/T [_name (de-meta _captured)])) - ) - captured) - (de-meta body*)) - - [meta ($ann value-expr type-expr type-type)] - ($ann (de-meta value-expr) nil nil) - - [meta ($var var-kind)] - ($var var-kind) - - [meta ($captured scope idx source)] - ($captured scope idx (de-meta source)) - - [meta ($proc proc-ident args special-args)] - (&/T ($proc proc-ident (&/|map de-meta args) special-args)) - - [meta not-interesting] - not-interesting - )) - (defn ^:private shift-function-body [own-body? body] "(-> Optimized Optimized)" - (|case body - [meta ($variant idx is-last? value)] - (&/T [meta ($variant idx is-last? (shift-function-body own-body? value))]) - - [meta ($tuple elems)] - (&/T [meta ($tuple (&/|map (partial shift-function-body own-body?) elems))]) - - [meta ($apply func args)] - (&/T [meta ($apply (shift-function-body own-body? func) - (&/|map (partial shift-function-body own-body?) args))]) - - [meta ($case value branches)] - (&/T [meta ($case (shift-function-body own-body? value) - (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [(if own-body? - (shift-pattern _pattern) - _pattern) - (shift-function-body own-body? _body)]))) - branches))]) - - [meta ($function arity scope captured body*)] - (&/T [meta ($function arity - (de-scope scope) - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - (&/T [_name (&/T [_meta ($captured (de-scope _scope) _idx (shift-function-body own-body? _source))])]))) - captured) - (shift-function-body false body*))]) - - [meta ($ann value-expr type-expr type-type)] - (&/T [meta ($ann (shift-function-body own-body? value-expr) - type-expr - type-type)]) - - [meta ($var var-kind)] - (if own-body? - (|case var-kind - (&/$Local 0) - (&/T [meta ($apply body - (&/|list [meta ($var (&/$Local 1))]))]) - - (&/$Local idx) - (&/T [meta ($var (&/$Local (inc idx)))]) - - (&/$Global ?module ?name) + (|let [[meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (shift-function-body own-body? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial shift-function-body own-body?) elems))]) + + ($apply func args) + (&/T [meta ($apply (shift-function-body own-body? func) + (&/|map (partial shift-function-body own-body?) args))]) + + ($case value branches) + (&/T [meta ($case (shift-function-body own-body? value) + (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [(if own-body? + (shift-pattern _pattern) + _pattern) + (shift-function-body own-body? _body)]))) + branches))]) + + ($function arity scope captured body*) + (&/T [meta ($function arity + (de-scope scope) + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name (&/T [_meta ($captured (de-scope _scope) _idx (shift-function-body own-body? _source))])]))) + captured) + (shift-function-body false body*))]) + + ($ann value-expr type-expr type-type) + (&/T [meta ($ann (shift-function-body own-body? value-expr) + type-expr + type-type)]) + + ($var var-kind) + (if own-body? + (|case var-kind + (&/$Local 0) + (&/T [meta ($apply body + (&/|list [meta ($var (&/$Local 1))]))]) + + (&/$Local idx) + (&/T [meta ($var (&/$Local (inc idx)))]) + + (&/$Global ?module ?name) + body) body) - body) - - [meta ($captured scope idx source)] - (if own-body? - source - (|case scope - (&/$Cons _ (&/$Cons _ (&/$Nil))) + + ($captured scope idx source) + (if own-body? source + (|case scope + (&/$Cons _ (&/$Cons _ (&/$Nil))) + source - _ - (&/T [meta ($captured (de-scope scope) idx (shift-function-body own-body? source))])) - ) - - [meta ($proc proc-ident args special-args)] - (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)]) + _ + (&/T [meta ($captured (de-scope scope) idx (shift-function-body own-body? source))])) + ) + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)]) - not-interesting - not-interesting - )) + _ + body + ))) (defn ^:private optimize-closure [optimize closure] (&/|map (fn [capture] @@ -181,58 +136,59 @@ ;; [Exports] (defn optimize [analysis] "(-> Analysis Optimized)" - (|case analysis - [meta (&-base/$bool value)] - (&/T [meta ($bool value)]) - - [meta (&-base/$int value)] - (&/T [meta ($int value)]) - - [meta (&-base/$real value)] - (&/T [meta ($real value)]) - - [meta (&-base/$char value)] - (&/T [meta ($char value)]) - - [meta (&-base/$text value)] - (&/T [meta ($text value)]) - - [meta (&-base/$variant idx is-last? value)] - (&/T [meta ($variant idx is-last? (optimize value))]) - - [meta (&-base/$tuple elems)] - (&/T [meta ($tuple (&/|map optimize elems))]) - - [meta (&-base/$apply func args)] - (&/T [meta ($apply (optimize func) (&/|map optimize args))]) - - [meta (&-base/$case value branches)] - (&/T [meta ($case (optimize value) - (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (optimize _body)]))) - branches))]) - - [meta (&-base/$lambda scope captured body)] - (|case (optimize body) - [_ ($function _arity _scope _captured _body)] - (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))]) - - =body - (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)])) - - [meta (&-base/$ann value-expr type-expr type-type)] - (&/T [meta ($ann (optimize value-expr) type-expr type-type)]) - - [meta (&-base/$var var-kind)] - (&/T [meta ($var var-kind)]) - - [meta (&-base/$captured scope idx source)] - (&/T [meta ($captured scope idx (optimize source))]) - - [meta (&-base/$proc proc-ident args special-args)] - (&/T [meta ($proc proc-ident (&/|map optimize args) special-args)]) - - _ - (assert false (prn-str 'optimize (&/adt->text analysis))) - )) + (|let [[meta analysis-] analysis] + (|case analysis- + (&-base/$bool value) + (&/T [meta ($bool value)]) + + (&-base/$int value) + (&/T [meta ($int value)]) + + (&-base/$real value) + (&/T [meta ($real value)]) + + (&-base/$char value) + (&/T [meta ($char value)]) + + (&-base/$text value) + (&/T [meta ($text value)]) + + (&-base/$variant idx is-last? value) + (&/T [meta ($variant idx is-last? (optimize value))]) + + (&-base/$tuple elems) + (&/T [meta ($tuple (&/|map optimize elems))]) + + (&-base/$apply func args) + (&/T [meta ($apply (optimize func) (&/|map optimize args))]) + + (&-base/$case value branches) + (&/T [meta ($case (optimize value) + (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (optimize _body)]))) + branches))]) + + (&-base/$lambda scope captured body) + (|case (optimize body) + [_ ($function _arity _scope _captured _body)] + (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))]) + + =body + (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)])) + + (&-base/$ann value-expr type-expr type-type) + (&/T [meta ($ann (optimize value-expr) type-expr type-type)]) + + (&-base/$var var-kind) + (&/T [meta ($var var-kind)]) + + (&-base/$captured scope idx source) + (&/T [meta ($captured scope idx (optimize source))]) + + (&-base/$proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map optimize args) special-args)]) + + _ + (assert false (prn-str 'optimize (&/adt->text analysis))) + ))) |