git.iko.soy/elk
on master help sign in
switch to smaller/safer representation for canonical env

Gets rid of the Data.Map.Internal usage that was used to allocate less. The replacement is an actual model of the data that we are working with, capturing the fact that "empty dictionary" is not a possibility. It also throws away some data when things are ambiguous, and it should allocate less overall.

commit56e3d05d766e1755846232fabe558c7da9224e06 authorEvan Czaplicki <evancz@users.noreply.github.com> dateThu 16 Jan 2020, 20:00 (7 years ago) parent8a4b62e
5 files changed+122−76
compare with master
unifiedsplit
compiler/src/Canonicalize/Environment.hs+50−20 compiler/src/Canonicalize/Environment/Foreign.hs+42−30 compiler/src/Canonicalize/Environment/Local.hs+5−5 compiler/src/Canonicalize/Expression.hs+6−7 compiler/src/Reporting/Error/Canonicalize.hs+19−14
compiler/src/Canonicalize/Environment.hs+50−20
@@ -4,6 +4,8 @@ module Canonicalize.Environment
44 ( Env(..)
55 , Exposed
66 , Qualified
7+ , Info(..)
8+ , mergeInfo
79 , Var(..)
810 , Type(..)
911 , Ctor(..)
@@ -20,8 +22,8 @@ module Canonicalize.Environment
2022
2123import qualified Data.Map.Merge.Strict as Map
2224import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Strict.Internal as I
2425import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
2527
2628import qualified AST.Utils.Binop as Binop
2729import qualified AST.Canonical as Can
@@ -58,11 +60,34 @@ data Env =
5860
5961
6062type Exposed a =
61− Map.Map Name.Name (Map.Map ModuleName.Canonical a)
63+ Map.Map Name.Name (Info a)
6264
6365
6466type Qualified a =
65− Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
67+ Map.Map Name.Name (Map.Map Name.Name (Info a))
68+
69+
70+
71+-- INFO
72+
73+
74+data Info a
75+ = Specific ModuleName.Canonical a
76+ | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77+
78+
79+mergeInfo :: Info a -> Info a -> Info a
80+mergeInfo info1 info2 =
81+ case info1 of
82+ Specific h1 _ ->
83+ case info2 of
84+ Specific h2 _ -> Ambiguous h1 (OneOrMore.one h2)
85+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86+
87+ Ambiguous h1 hs1 ->
88+ case info2 of
89+ Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
6691
6792
6893
@@ -72,7 +97,8 @@ type Qualified a =
7297data Var
7398 = Local A.Region
7499 | TopLevel A.Region
75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
76102
77103
78104
@@ -139,7 +165,10 @@ addLocalLeft _ region =
139165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
140166addLocalBoth name region var =
141167 case var of
142− Foreign _ ->
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
143172 Result.ok (Local region)
144173
145174 Local parentRegion ->
@@ -150,17 +179,18 @@ addLocalBoth name region var =
150179
151180
152181
182+
153183-- FIND TYPE
154184
155185
156186findType :: A.Region -> Env -> Name.Name -> Result i w Type
157187findType region (Env _ _ ts _ _ _ qts _) name =
158188 case Map.lookup name ts of
159− Just (I.Bin 1 _ tipe _ _) ->
189+ Just (Specific _ tipe) ->
160190 Result.ok tipe
161191
162− Just homes ->
163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
192+ Just (Ambiguous h hs) ->
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
164194
165195 Nothing ->
166196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -171,11 +201,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
171201 case Map.lookup prefix qts of
172202 Just qualified ->
173203 case Map.lookup name qualified of
174− Just (I.Bin 1 _ tipe _ _) ->
204+ Just (Specific _ tipe) ->
175205 Result.ok tipe
176206
177− Just homes ->
178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
207+ Just (Ambiguous h hs) ->
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
179209
180210 Nothing ->
181211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -191,11 +221,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
191221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
192222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
193223 case Map.lookup name cs of
194− Just (I.Bin 1 _ ctor _ _) ->
224+ Just (Specific _ ctor) ->
195225 Result.ok ctor
196226
197− Just homes ->
198− Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
227+ Just (Ambiguous h hs) ->
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
199229
200230 Nothing ->
201231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -206,11 +236,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
206236 case Map.lookup prefix qcs of
207237 Just qualified ->
208238 case Map.lookup name qualified of
209− Just (I.Bin 1 _ pattern _ _) ->
239+ Just (Specific _ pattern) ->
210240 Result.ok pattern
211241
212− Just homes ->
213− Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
242+ Just (Ambiguous h hs) ->
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
214244
215245 Nothing ->
216246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -226,11 +256,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
226256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
227257findBinop region (Env _ _ _ _ binops _ _ _) name =
228258 case Map.lookup name binops of
229− Just (I.Bin 1 _ binop _ _) ->
259+ Just (Specific _ binop) ->
230260 Result.ok binop
231261
232− Just homes ->
233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
262+ Just (Ambiguous h hs) ->
263+ Result.throw (Error.AmbiguousBinop region name h hs)
234264
235265 Nothing ->
236266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Foreign.hs+42−30
@@ -35,7 +35,14 @@ type Result i w a =
3535createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
3636createInitialEnv home ifaces imports =
3737 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
38+ Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
39+
40+
41+infoToVar :: Env.Info Can.Annotation -> Env.Var
42+infoToVar info =
43+ case info of
44+ Env.Specific home tipe -> Env.Foreign home tipe
45+ Env.Ambiguous h hs -> Env.Foreigns h hs
3946
4047
4148
@@ -61,7 +68,7 @@ emptyState =
6168
6269emptyTypes :: Env.Exposed Env.Type
6370emptyTypes =
64− Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
71+ Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
6572
6673
6774
@@ -102,8 +109,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
102109 (Map.mapMaybeWithKey (unionToType home) unions)
103110 (Map.mapMaybeWithKey (aliasToType home) aliases)
104111
105− !vars = Map.map (Map.singleton home) defs
106− !types = Map.map (Map.singleton home . fst) rawTypeInfo
112+ !vars = Map.map (Env.Specific home) defs
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
107114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
108115
109116 !qvs2 = addQualified prefix vars qvs
@@ -129,7 +136,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
129136
130137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
131138addExposed =
132− Map.unionWith Map.union
139+ Map.unionWith Env.mergeInfo
133140
134141
135142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -150,7 +157,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
150157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
151158 let
152159 addCtor dict (Can.Ctor ctor index _ args) =
153− Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
154161 in
155162 ( Env.Union (length vars) home
156163 , List.foldl' addCtor Map.empty ctors
@@ -181,7 +188,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
181188 (Can.TAlias home name avars (Can.Filled tipe))
182189 (Can.fieldsToList fields)
183190 in
184− Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
185192
186193 _ ->
187194 Map.empty
@@ -192,9 +199,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
192199-- BINOP
193200
194201
195−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
196203binopToBinop home op (I.Binop name annotation associativity precedence) =
197− Map.singleton home (Env.Binop op home name annotation associativity precedence)
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
198205
199206
200207
@@ -214,7 +221,7 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
214221 Src.Lower (A.At region name) ->
215222 case Map.lookup name vars of
216223 Just info ->
217− Result.ok (State (Map.insertWith Map.union name info vs) ts cs bs qvs qts qcs)
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
218225
219226 Nothing ->
220227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
@@ -227,23 +234,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
227234 case tipe of
228235 Env.Union _ _ ->
229236 let
230− !ts2 = Map.insert name (Map.singleton home tipe) ts
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
231238 in
232239 Result.ok (State vs ts2 cs bs qvs qts qcs)
233240
234241 Env.Alias _ _ _ _ ->
235242 let
236− !ts2 = Map.insert name (Map.singleton home tipe) ts
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
237244 !cs2 = addExposed cs ctors
238245 in
239246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
240247
241248 Nothing ->
242− case Map.lookup name (toCtors types) of
243− Just tipe ->
249+ case checkForCtorMistake name types of
250+ tipe:_ ->
244251 Result.throw $ Error.ImportCtorByName region name tipe
245252
246− Nothing ->
253+ [] ->
247254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
248255
249256 Src.Public dotDotRegion ->
@@ -252,7 +259,7 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
252259 case tipe of
253260 Env.Union _ _ ->
254261 let
255− !ts2 = Map.insert name (Map.singleton home tipe) ts
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
256263 !cs2 = addExposed cs ctors
257264 in
258265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
@@ -275,18 +282,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
275282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
276283
277284
278−
279−toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
280−toCtors types =
281− Map.foldr addCtors Map.empty types
285+checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
286+checkForCtorMistake givenName types =
287+ Map.foldr addMatches [] types
282288 where
283− addCtors (_, exposedCtors) dict =
284− Map.foldrWithKey addCtor dict exposedCtors
285−
286− addCtor ctorName homes dict =
287− case Map.elems homes of
288− [Env.Ctor _ tipeName _ _ _] ->
289− Map.insert ctorName tipeName dict
290−
291− _ ->
292− dict
289+ addMatches (_, exposedCtors) matches =
290+ Map.foldrWithKey addMatch matches exposedCtors
291+
292+ addMatch ctorName info matches =
293+ if ctorName /= givenName
294+ then matches
295+ else
296+ case info of
297+ Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
298+ tipeName : matches
299+
300+ Env.Specific _ (Env.RecordCtor _ _ _) ->
301+ matches
302+
303+ Env.Ambiguous _ _ ->
304+ matches
compiler/src/Canonicalize/Environment/Local.hs+5−5
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
110110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112112 do arity <- checkUnionFreeVars union
113− let one = Map.singleton home (Env.Union arity home)
113+ let one = Env.Specific home (Env.Union arity home)
114114 Result.ok $ Map.insert name one types
115115
116116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134134 do args <- checkAliasFreeVars alias
135135 ctype <- Type.canonicalize env tipe
136− let one = Map.singleton home (Env.Alias (length args) home args ctype)
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
137137 let ts1 = Map.insert name one ts
138138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139139
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281281 )
282282
283283
284−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
285285
286286
287287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297297 ,
298298 case ctipe of
299299 Can.TRecord fields Nothing ->
300− Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301301
302302 _ ->
303303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351351
352352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Map.singleton home $
354+ Dups.one name region $ Env.Specific home $
355355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+6−7
@@ -14,7 +14,6 @@ import Control.Monad (foldM)
1414import qualified Data.Graph as Graph
1515import qualified Data.List as List
1616import qualified Data.Map.Strict as Map
17−import qualified Data.Map.Strict.Internal as I
1817import qualified Data.Name as Name
1918
2019import qualified AST.Canonical as Can
@@ -696,15 +695,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
696695 Env.TopLevel _ ->
697696 logVar name (Can.VarTopLevel localHome name)
698697
699− Env.Foreign (I.Bin 1 home annotation _ _) ->
698+ Env.Foreign home annotation ->
700699 Result.ok $
701700 if home == ModuleName.debug then
702701 Can.VarDebug localHome name annotation
703702 else
704703 Can.VarForeign home name annotation
705704
706− Env.Foreign homes ->
707− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
705+ Env.Foreigns h hs ->
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
708707
709708 Nothing ->
710709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -715,15 +714,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
715714 case Map.lookup prefix qvs of
716715 Just qualified ->
717716 case Map.lookup name qualified of
718− Just (I.Bin 1 home annotation _ _) ->
717+ Just (Env.Specific home annotation) ->
719718 Result.ok $
720719 if home == ModuleName.debug then
721720 Can.VarDebug localHome name annotation
722721 else
723722 Can.VarForeign home name annotation
724723
725− Just homes ->
726− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
724+ Just (Env.Ambiguous h hs) ->
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
727726
728727 Nothing ->
729728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Reporting/Error/Canonicalize.hs+19−14
@@ -14,8 +14,10 @@ module Reporting.Error.Canonicalize
1414
1515
1616import qualified Data.Char as Char
17+import qualified Data.List as List
1718import qualified Data.Map as Map
1819import qualified Data.Name as Name
20+import qualified Data.OneOrMore as OneOrMore
1921import qualified Data.Set as Set
2022
2123import qualified AST.Canonical as Can
@@ -37,10 +39,10 @@ import qualified Reporting.Suggest as Suggest
3739
3840data Error
3941 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
40− | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
41− | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
42− | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
43− | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical]
42+ | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
43+ | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
44+ | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
45+ | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
4446 | BadArity A.Region BadArityContext Name.Name Int Int
4547 | Binop A.Region Name.Name Name.Name
4648 | DuplicateDecl Name.Name A.Region A.Region
@@ -164,17 +166,17 @@ toReport source err =
164166 <> " be deleted? Maybe some parentheses are missing?"
165167 )
166168
167− AmbiguousVar region maybePrefix name possibleHomes ->
168− ambiguousName source region maybePrefix name possibleHomes "variable"
169+ AmbiguousVar region maybePrefix name h hs ->
170+ ambiguousName source region maybePrefix name h hs "variable"
169171
170− AmbiguousType region maybePrefix name possibleHomes ->
171− ambiguousName source region maybePrefix name possibleHomes "type"
172+ AmbiguousType region maybePrefix name h hs ->
173+ ambiguousName source region maybePrefix name h hs "type"
172174
173− AmbiguousVariant region maybePrefix name possibleHomes ->
174− ambiguousName source region maybePrefix name possibleHomes "variant"
175+ AmbiguousVariant region maybePrefix name h hs ->
176+ ambiguousName source region maybePrefix name h hs "variant"
175177
176− AmbiguousBinop region name possibleHomes ->
177− ambiguousName source region Nothing name possibleHomes "operator"
178+ AmbiguousBinop region name h hs ->
179+ ambiguousName source region Nothing name h hs "operator"
178180
179181 BadArity region badArityContext name expected actual ->
180182 let
@@ -974,8 +976,11 @@ nameClash source r1 r2 messageThatEndsWithPunctuation =
974976-- AMBIGUOUS NAME
975977
976978
977−ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report
978−ambiguousName source region maybePrefix name possibleHomes thing =
979+ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
980+ambiguousName source region maybePrefix name h hs thing =
981+ let
982+ possibleHomes = List.sort (h : OneOrMore.destruct (:) hs)
983+ in
979984 Report.Report "AMBIGUOUS NAME" region [] $
980985 Code.toSnippet source region Nothing $
981986 case maybePrefix of