From 1f0be2351bc76b0de15d97691f8ea0728d9ab321 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 23:06:19 -0400 Subject: - Added a simple optimization based on the idea of avoiding to compare 2 type-functions which are most-likely the same, due to their name (remembering that when you define types using deftype, the type-function's name will correspond to the def's). - Gave empty environments to top-level type-functions, instead of leaving them with unset environments. --- source/lux.lux | 70 ++++++++++++++++++++++++++++---------------------------- src/lux/type.clj | 68 ++++++++++++++++++++++++++++-------------------------- 2 files changed, 70 insertions(+), 68 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index e3f3ba243..9b5601eb4 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -37,10 +37,10 @@ ## (| #Nil ## (#Cons (, a (List a))))) (_lux_def List - (#AllT [#None "List" "a" + (#AllT [(#Some #Nil) "lux;List" "a" (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) #Nil])]))] #Nil])]))])) (_lux_export List) @@ -49,7 +49,7 @@ ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [#None "Maybe" "a" + (#AllT [(#Some #Nil) "lux;Maybe" "a" (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] (#Cons [["lux;Some" (#BoundT "a")] #Nil])]))])) @@ -70,7 +70,7 @@ Type (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) TypeEnv - (#AppT [(#AllT [#None "Type" "_" + (#AppT [(#AllT [(#Some #Nil) "Type" "_" (#VariantT (#Cons [["lux;DataT" Text] (#Cons [["lux;TupleT" (#AppT [List Type])] (#Cons [["lux;VariantT" TypeEnv] @@ -89,7 +89,7 @@ ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [#None "Bindings" "k" + (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;counter" Int] (#Cons [["lux;mappings" (#AppT [List @@ -104,7 +104,7 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [#None "Env" "k" + (#AllT [(#Some #Nil) "lux;Env" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;name" Text] (#Cons [["lux;inner-closures" Int] @@ -122,7 +122,7 @@ ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (_lux_def Meta - (#AllT [#None "Meta" "m" + (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") (#Cons [(#BoundT "v") @@ -143,12 +143,12 @@ ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") + (#AppT [(#BoundT "lux;Syntax'") (#BoundT "w")])]) Syntax (_lux_case (#AppT [List Syntax]) SyntaxList - (#AllT [#None "Syntax'" "w" + (#AllT [(#Some #Nil) "lux;Syntax'" "w" (#VariantT (#Cons [["lux;BoolS" Bool] (#Cons [["lux;IntS" Int] (#Cons [["lux;RealS" Real] @@ -178,7 +178,7 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [#None "_" "l" + (#AllT [(#Some #Nil) "lux;Either" "l" (#AllT [#None "" "r" (#VariantT (#Cons [["lux;Left" (#BoundT "l")] (#Cons [["lux;Right" (#BoundT "r")] @@ -188,7 +188,7 @@ ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#None "StateE" "s" + (#AllT [(#Some #Nil) "lux;StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) @@ -218,7 +218,7 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [#None "DefData'" "" + (#AllT [(#Some #Nil) "lux;DefData'" "" (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] (#Cons [["lux;ValueD" Type] (#Cons [["lux;MacroD" (#BoundT "")] @@ -234,20 +234,20 @@ #Nil])]))) (_lux_export LuxVar) -## (deftype #rec CompilerState +## (deftype #rec Compiler ## (& #source Reader -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) +## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) -(_lux_def CompilerState - (#AppT [(#AllT [#None "CompilerState" "" +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#AppT [(#AppT [StateE (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) SyntaxList])])]) #Nil])])) @@ -261,13 +261,13 @@ (#Cons [["lux;seed" Int] #Nil])])])])])])]))]) Void])) -(_lux_export CompilerState) +(_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE CompilerState (List Syntax)))) +## (-> (List Syntax) (StateE Compiler (List Syntax)))) (_lux_def Macro (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) + (#AppT [(#AppT [StateE Compiler]) SyntaxList])])) (_lux_export Macro) @@ -284,15 +284,15 @@ ## (def (return x) ## (All [a] -## (-> a CompilerState -## (Either Text (, CompilerState a)))) +## (-> a Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ val @@ -301,15 +301,15 @@ ## (def (fail msg) ## (All [a] -## (-> Text CompilerState -## (Either Text (, CompilerState a)))) +## (-> Text Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [Text - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ msg @@ -911,11 +911,11 @@ (fail "Wrong syntax for if"))) ## (deftype (Lux a) -## (-> CompilerState (Either Text (, CompilerState a)))) +## (-> Compiler (Either Text (, Compiler a)))) (def__ #export Lux Type (All' [a] - (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a))))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1246,7 +1246,7 @@ (replace-syntax replacements body) (reverse targs))] (return (_lux_: SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) #None (fail "'All' arguments must be symbols.")) @@ -1281,7 +1281,7 @@ (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) + (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad @@ -1949,7 +1949,7 @@ #seed seed} (case (get "lux" modules) (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] diff --git a/src/lux/type.clj b/src/lux/type.clj index 105528b8a..a2cf83624 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -16,14 +16,14 @@ (def $Void (&/V "lux;VariantT" (&/|list))) (def List - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "List" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "List") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") (&/V "lux;BoundT" "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Maybe" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) @@ -31,7 +31,7 @@ (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Type" "_" + (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) (&/T "lux;VariantT" TypeEnv) @@ -49,7 +49,7 @@ (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) (def Bindings - (fAll "Bindings" "k" + (fAll "lux;Bindings" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) (&/T "lux;mappings" (&/V "lux;AppT" (&/T List @@ -59,7 +59,7 @@ (def Env (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) (&/V "lux;BoundT" "v")))] - (fAll "Env" "k" + (fAll "lux;Env" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;name" Text) @@ -72,7 +72,7 @@ (&/V "lux;TupleT" (&/|list Text Int Int))) (def Meta - (fAll "Meta" "m" + (fAll "lux;Meta" "m" (fAll "" "v" (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") (&/V "lux;BoundT" "v"))))))))) @@ -81,10 +81,10 @@ (def Syntax* (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Syntax'") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") (&/V "lux;BoundT" "w"))))) Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "Syntax'" "w" + (fAll "lux;Syntax'" "w" (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) (&/T "lux;IntS" Int) (&/T "lux;RealS" Real) @@ -104,13 +104,13 @@ (def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) (def Either - (fAll "_" "l" + (fAll "lux;Either" "l" (fAll "" "r" (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) (def StateE - (fAll "StateE" "s" + (fAll "lux;StateE" "s" (fAll "" "a" (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) @@ -129,7 +129,7 @@ ))) (def DefData* - (fAll "DefData'" "" + (fAll "lux;DefData'" "" (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) (&/T "lux;ValueD" Type) (&/T "lux;MacroD" (&/V "lux;BoundT" "")) @@ -139,8 +139,8 @@ (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) -(def CompilerState - (&/V "lux;AppT" (&/T (fAll "CompilerState" "" +(def $Compiler + (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" (&/V "lux;RecordT" (&/|list (&/T "lux;source" Reader) (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" @@ -150,7 +150,7 @@ (&/V "lux;TupleT" (&/|list Bool (&/V "lux;AppT" (&/T DefData* (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "CompilerState") + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" ""))))) SyntaxList))))))))))))))))) (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void))) @@ -164,7 +164,7 @@ (def Macro (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE CompilerState)) + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) SyntaxList))))) (defn bound? [id] @@ -433,23 +433,25 @@ (and (type= xlambda ylambda) (type= xparam yparam)) [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (and (= xname yname) - (= xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] - ;; true - - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - ) + (or (and (not= "" xname) + (= xname yname)) + (and (= xname yname) + (= xarg yarg) + ;; (matchv ::M/objects [xenv yenv] + ;; [["lux;None" _] ["lux;None" _]] + ;; true + + ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] + ;; (&/fold (fn [old bname] + ;; (and old + ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) + ;; (= (&/|length xenv*) (&/|length yenv*)) + ;; (&/|keys xenv*)) + + ;; [_ _] + ;; false) + (type= xbody ybody) + )) [_ _] false -- cgit v1.2.3