5fcbf86 · elk · git.iko.soy

git.iko.soy/elk

Improve duplicate tracking a bit.

The old version builds Bags as you go, turning it into dictionary at the end. That means adding things is O(1) and then you pay O(n log(n)) at the end to build the dictionary. The new one has it as a dictionary all the way through. That means each insert is O(log(n)) and you end up doing that O(n) times in the worst case. But you also end up using Dups.union which is faster than inserting each entry individually. So the theory is that this should result in a bit less allocation and be a bit faster.

commit5fcbf8647523131da2cf810f44bb6f1304777206 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 15 Nov 2017, 18:25 (9 years ago) parent6709d6f

5 files changed+137−107

compare with master

unifiedsplit

src/Canonicalize/Environment/Dups.hs+48−18 src/Canonicalize/Environment/Local.hs+38−37 src/Canonicalize/Expression.hs+25−25 src/Canonicalize/Module.hs+8−8 src/Canonicalize/Pattern.hs+18−19

src/Canonicalize/Environment/Dups.hs+48−18

@@ -1,8 +1,12 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Canonicalize.Environment.Dups

4− ( Info(Info)

5− , info

4+ ( Dict

5+ , none

6+ , one

7+ , union

8+ , unions

9+ , insert

610 , detect

711 , checkFields

812 )

@@ -12,6 +16,7 @@ module Canonicalize.Environment.Dups

1216import qualified Data.Map as Map

1317

1418import Canonicalize.Environment.Internals (Result)

19+import qualified Data.OneOrMore as OneOrMore

1520import qualified Elm.Name as N

1621import qualified Reporting.Annotation as A

1722import qualified Reporting.Error.Canonicalize as Error

@@ -23,6 +28,10 @@ import qualified Reporting.Result as Result

2328-- INFO

2429

2530

31+type Dict category value =

32+ Map.Map N.Name (OneOrMore.OneOrMore (Info category value))

33+

34+

2635data Info category value =

2736 Info

2837 { _region :: R.Region

@@ -31,10 +40,29 @@ data Info category value =

3140 }

3241

3342

34−{-# INLINE info #-}

35−info :: N.Name -> R.Region -> category -> value -> ( N.Name, [Info category value] )

36−info name region category value =

37− ( name, [Info region category value] )

43+none :: Dict c v

44+none =

45+ Map.empty

46+

47+

48+one :: N.Name -> R.Region -> category -> value -> Dict category value

49+one name region category value =

50+ Map.singleton name (OneOrMore.one (Info region category value))

51+

52+

53+union :: Dict c v -> Dict c v -> Dict c v

54+union a b =

55+ Map.unionWith OneOrMore.more a b

56+

57+

58+unions :: [Dict c v] -> Dict c v

59+unions dicts =

60+ Map.unionsWith OneOrMore.more dicts

61+

62+

63+insert :: N.Name -> R.Region -> c -> v -> Dict c v -> Dict c v

64+insert name region category value dict =

65+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region category value)) dict

3866

3967

4068

@@ -45,22 +73,23 @@ type ToError c =

4573 N.Name -> c -> c -> Error.Error

4674

4775

48−detect :: ToError c -> [(N.Name, [Info c v])] -> Result () (Map.Map N.Name v)

49−detect toError pairs =

50− Map.traverseWithKey (detectHelp toError) $ Map.fromListWith (++) pairs

76+detect :: ToError c -> Dict c v -> Result () (Map.Map N.Name v)

77+detect toError dict =

78+ Map.traverseWithKey (detectHelp toError) dict

5179

5280

53−detectHelp :: ToError c -> N.Name -> [Info c v] -> Result () v

81+detectHelp :: ToError c -> N.Name -> OneOrMore.OneOrMore (Info c v) -> Result () v

5482detectHelp toError name values =

5583 case values of

56− [Info _ _ value] ->

84+ OneOrMore.One (Info _ _ value) ->

5785 Result.ok value

5886

59− [] ->

60− error "impossible: use a non-empty data structure to rule this out"

61−

62− Info region1 category1 _ : Info region2 category2 _ : _ ->

63− Result.throw (max region1 region2) (toError name category1 category2)

87+ OneOrMore.More _ _ ->

88+ let

89+ (Info r1 c1 _ : Info r2 c2 _ : _) =

90+ OneOrMore.toList values

91+ in

92+ Result.throw (max r1 r2) (toError name c1 c2)

6493

6594

6695

@@ -71,9 +100,10 @@ checkFields :: [(A.Located N.Name, a)] -> Result () (Map.Map N.Name a)

71100checkFields fields =

72101 let

73102 toInfo (A.A region name, value) =

74− info name region () value

103+ Map.singleton name (OneOrMore.one (Info region () value))

75104

76105 toError name () () =

77106 Error.DuplicateField name

78107 in

79− detect toError $ map toInfo fields

108+ detect toError $

109+ Map.unionsWith OneOrMore.more (map toInfo fields)

src/Canonicalize/Environment/Local.hs+38−37

@@ -135,59 +135,58 @@ addVarsHelp localVars vars =

135135collectLowerVars :: Valid.Module -> Result (Map.Map N.Name ())

136136collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =

137137 let

138− declToInfo (A.A _ (Valid.Decl (A.A region name) _ _ _)) =

139− Dups.info name region () ()

138+ addDecl (A.A _ (Valid.Decl (A.A region name) _ _ _)) dict =

139+ Dups.insert name region () () dict

140140

141− portToInfo (Valid.Port (A.A region name) _) =

142− Dups.info name region () ()

141+ addPort (Valid.Port (A.A region name) _) dict =

142+ Dups.insert name region () () dict

143143

144− effectInfo =

144+ effectDict =

145145 case effects of

146146 Valid.NoEffects ->

147− []

147+ Dups.none

148148

149149 Valid.Ports ports ->

150− map portToInfo ports

150+ foldr addPort Dups.none ports

151151

152152 Valid.Manager _ manager ->

153153 case manager of

154154 Valid.Cmd (A.A region _) ->

155− [ Dups.info "command" region () () ]

155+ Dups.one "command" region () ()

156156

157157 Valid.Sub (A.A region _) ->

158− [ Dups.info "subscription" region () () ]

158+ Dups.one "subscription" region () ()

159159

160160 Valid.Fx (A.A regionCmd _) (A.A regionSub _) ->

161− [ Dups.info "command" regionCmd () ()

162− , Dups.info "subscription" regionSub () ()

163− ]

161+ Dups.union

162+ (Dups.one "command" regionCmd () ())

163+ (Dups.one "subscription" regionSub () ())

164164

165165 toError name () () =

166166 Error.DuplicateDecl name

167167 in

168− Dups.detect toError $

169− effectInfo ++ map declToInfo decls

168+ Dups.detect toError $ foldr addDecl effectDict decls

170169

171170

172171collectUpperVars :: Valid.Module -> Result (Map.Map N.Name ())

173172collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =

174173 let

175− unionToInfos (Valid.Union (A.A _ name) _ ctors) =

176− map (ctorToInfo name) ctors

174+ addUnion (Valid.Union (A.A _ name) _ ctors) dict =

175+ foldr (addCtor name) dict ctors

177176

178− ctorToInfo tipe (A.A region name, _args) =

179− Dups.info name region (Error.UnionCtor tipe) ()

177+ addCtor tipe (A.A region name, _args) dict =

178+ Dups.insert name region (Error.UnionCtor tipe) () dict

180179

181− aliasToInfos (Valid.Alias (A.A region name) _ (A.A _ tipe)) =

180+ addAlias (Valid.Alias (A.A region name) _ (A.A _ tipe)) dict =

182181 case tipe of

183182 Src.TRecord _ Nothing ->

184− [ Dups.info name region Error.RecordCtor () ]

183+ Dups.insert name region Error.RecordCtor () dict

185184

186185 _ ->

187− []

186+ dict

188187 in

189188 Dups.detect Error.DuplicateCtor $

190− concatMap aliasToInfos aliases ++ concatMap unionToInfos unions

189+ foldr addAlias (foldr addUnion Dups.none unions) aliases

191190

192191

193192

@@ -197,23 +196,25 @@ collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =

197196addTypes :: Valid.Module -> Env.Env -> Result Env.Env

198197addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =

199198 let

200− aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =

199+ aliasToDict alias@(Valid.Alias (A.A region name) _ tipe) =

201200 do args <- checkAliasFreeVars alias

202− return $ Dups.info name region () (Left (Alias region name args tipe))

201+ return $ Dups.one name region () (Left (Alias region name args tipe))

203202

204− unionToInfo union@(Valid.Union (A.A region name) _ _) =

203+ unionToDict union@(Valid.Union (A.A region name) _ _) =

205204 do arity <- checkUnionFreeVars union

206− return $ Dups.info name region () (Right arity)

205+ return $ Dups.one name region () (Right arity)

207206

208207 toError name () () =

209208 Error.DuplicateType name

210209

211− infos =

212− liftA2 (++)

213− (traverse aliasToInfo aliases)

214− (traverse unionToInfo unions)

210+ combineDicts dicts1 dicts2 =

211+ Dups.union (Dups.unions dicts1) (Dups.unions dicts2)

215212 in

216− do types <- Dups.detect toError =<< infos

213+ do dict <-

214+ liftA2 combineDicts

215+ (traverse aliasToDict aliases)

216+ (traverse unionToDict unions)

217+ types <- Dups.detect toError dict

217218 let (aliasDict, unionDict) = Map.mapEither id types

218219 addTypeAliases aliasDict (addUnionTypes unionDict env)

219220

@@ -326,8 +327,8 @@ getEdges (A.A _ tipe) =

326327checkUnionFreeVars :: Valid.Union -> Result Int

327328checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

328329 let

329− toInfo (A.A region arg) =

330− Dups.info arg region () region

330+ addUnion (A.A region arg) dict =

331+ Dups.insert arg region () region dict

331332

332333 toError badArg () () =

333334 Error.DuplicateUnionArg name badArg (map A.drop args)

@@ -335,7 +336,7 @@ checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

335336 addCtorFreeVars (_, tipes) freeVars =

336337 foldr addFreeVars freeVars tipes

337338 in

338− do boundVars <- Dups.detect toError (map toInfo args)

339+ do boundVars <- Dups.detect toError (foldr addUnion Dups.none args)

339340 let freeVars = foldr addCtorFreeVars Map.empty ctors

340341 case Map.toList (Map.difference freeVars boundVars) of

341342 [] ->

@@ -351,13 +352,13 @@ checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =

351352checkAliasFreeVars :: Valid.Alias -> Result [N.Name]

352353checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =

353354 let

354− toInfo (A.A region arg) =

355− Dups.info arg region () region

355+ addAlias (A.A region arg) dict =

356+ Dups.insert arg region () region dict

356357

357358 toError badArg () () =

358359 Error.DuplicateAliasArg name badArg (map A.drop args)

359360 in

360− do boundVars <- Dups.detect toError (map toInfo args)

361+ do boundVars <- Dups.detect toError (foldr addAlias Dups.none args)

361362 let freeVars = addFreeVars tipe Map.empty

362363 let overlap = Map.size (Map.intersection boundVars freeVars)

363364 if Map.size boundVars == overlap && Map.size freeVars == overlap

src/Canonicalize/Expression.hs+25−25

@@ -272,8 +272,8 @@ canonicalizeLet letRegion env defs body =

272272 addLocals $

273273 do let keyedDefs = zip defs [ 0 .. length defs ]

274274 let toError name () () = Error.DuplicatePattern Error.DPLetBinding name

275− let namesBag = foldr addBindings Bag.empty keyedDefs

276− boundNames <- Dups.detect toError (Bag.toList namesBag)

275+ let names = foldr addBindings Dups.none keyedDefs

276+ boundNames <- Dups.detect toError names

277277 newEnv <- Env.addLocals boundNames env

278278 let defKeys = Map.map A.drop boundNames

279279 nodes <- traverse (defToNode defKeys newEnv) keyedDefs

@@ -324,62 +324,62 @@ toUnusedWarning unused (name, A.A region _) =

324324-- ADD BINDINGS

325325

326326

327−type KeyBag =

328− Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )

327+type Bindings =

328+ Dups.Dict () (A.Located Int)

329329

330330

331−addBindings :: (Valid.Def, Int) -> KeyBag -> KeyBag

332−addBindings (def, key) bag =

331+addBindings :: (Valid.Def, Int) -> Bindings -> Bindings

332+addBindings (def, key) bindings =

333333 case def of

334334 Valid.Define defRegion (A.A region name) _ _ _ ->

335− Bag.insert (Dups.info name region () (A.A defRegion key)) bag

335+ Dups.insert name region () (A.A defRegion key) bindings

336336

337337 Valid.Destruct defRegion pattern _ ->

338− addBindingsHelp (A.A defRegion key) pattern bag

338+ addBindingsHelp (A.A defRegion key) pattern bindings

339339

340340

341−addBindingsHelp :: A.Located Int -> Src.Pattern -> KeyBag -> KeyBag

342−addBindingsHelp key (A.A region pattern) bag =

341+addBindingsHelp :: A.Located Int -> Src.Pattern -> Bindings -> Bindings

342+addBindingsHelp key (A.A region pattern) bindings =

343343 case pattern of

344344 Src.PAnything ->

345− bag

345+ bindings

346346

347347 Src.PVar name ->

348− Bag.insert (Dups.info name region () key) bag

348+ Dups.insert name region () key bindings

349349

350350 Src.PRecord fields ->

351351 let

352− fieldToInfo (A.A fieldRegion name) =

353− Dups.info name fieldRegion () key

352+ addField (A.A fieldRegion name) dict =

353+ Dups.insert name fieldRegion () key dict

354354 in

355− foldr (\f b -> Bag.insert (fieldToInfo f) b) bag fields

355+ foldr addField bindings fields

356356

357357 Src.PUnit ->

358− bag

358+ bindings

359359

360360 Src.PTuple a b cs ->

361− foldr (addBindingsHelp key) bag (a:b:cs)

361+ foldr (addBindingsHelp key) bindings (a:b:cs)

362362

363363 Src.PCtor _ _ _ patterns ->

364− foldr (addBindingsHelp key) bag patterns

364+ foldr (addBindingsHelp key) bindings patterns

365365

366366 Src.PList patterns ->

367− foldr (addBindingsHelp key) bag patterns

367+ foldr (addBindingsHelp key) bindings patterns

368368

369369 Src.PCons first rest ->

370− addBindingsHelp key rest (addBindingsHelp key first bag)

370+ addBindingsHelp key rest (addBindingsHelp key first bindings)

371371

372372 Src.PAlias ptrn (A.A reg name) ->

373− addBindingsHelp key ptrn (Bag.insert (Dups.info name reg () key) bag)

373+ addBindingsHelp key ptrn (Dups.insert name reg () key bindings)

374374

375375 Src.PChr _ ->

376− bag

376+ bindings

377377

378378 Src.PStr _ ->

379− bag

379+ bindings

380380

381381 Src.PInt _ ->

382− bag

382+ bindings

383383

384384

385385

@@ -450,7 +450,7 @@ toNode defKeys key args (Result.Result freeLocals warnings answer) =

450450-- GATHER TYPED ARGS

451451

452452

453−gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bag ([Can.TypedArg], Can.Type)

453+gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bindings ([Can.TypedArg], Can.Type)

454454gatherTypedArgs env name srcArgs tipe index revTypedArgs =

455455 case srcArgs of

456456 [] ->

src/Canonicalize/Module.hs+8−8

@@ -237,7 +237,7 @@ canonicalizeExports decls unions aliases binops effects exposing =

237237 do let names = Map.fromList (map declToName decls)

238238 infos <- traverse (checkExposed names unions aliases binops effects) exposeds

239239 let toError name () () = Error.ExportDuplicate name

240− Can.Export <$> Dups.detect toError infos

240+ Can.Export <$> Dups.detect toError (Dups.unions infos)

241241

242242

243243declToName :: A.Located Valid.Decl -> ( N.Name, () )

@@ -252,16 +252,16 @@ checkExposed

252252 -> Map.Map N.Name binop

253253 -> Can.Effects

254254 -> A.Located Src.Exposed

255− -> Result (N.Name, [Dups.Info () Can.Export])

255+ -> Result (Dups.Dict () Can.Export)

256256checkExposed decls unions aliases binops effects (A.A region exposed) =

257257 case exposed of

258258 Src.Lower name ->

259259 if Map.member name decls then

260− Result.ok (Dups.info name region () Can.ExportValue)

260+ Result.ok (Dups.one name region () Can.ExportValue)

261261 else

262262 case checkPorts effects name of

263263 Nothing ->

264− Result.ok (Dups.info name region () Can.ExportPort)

264+ Result.ok (Dups.one name region () Can.ExportPort)

265265

266266 Just ports ->

267267 Result.throw region $ Error.ExportNotFound Error.BadVar name $

@@ -269,14 +269,14 @@ checkExposed decls unions aliases binops effects (A.A region exposed) =

269269

270270 Src.Operator name ->

271271 if Map.member name binops then

272− Result.ok (Dups.info name region () Can.ExportBinop)

272+ Result.ok (Dups.one name region () Can.ExportBinop)

273273 else

274274 Result.throw region $ Error.ExportNotFound Error.BadOp name $

275275 Map.keys binops

276276

277277 Src.Upper name Src.Public ->

278278 if Map.member name unions then

279− Result.ok (Dups.info name region () Can.ExportUnionOpen)

279+ Result.ok (Dups.one name region () Can.ExportUnionOpen)

280280 else if Map.member name aliases then

281281 Result.throw region $ Error.ExportOpenAlias name

282282 else

@@ -285,9 +285,9 @@ checkExposed decls unions aliases binops effects (A.A region exposed) =

285285

286286 Src.Upper name Src.Private ->

287287 if Map.member name unions then

288− Result.ok (Dups.info name region () Can.ExportUnionClosed)

288+ Result.ok (Dups.one name region () Can.ExportUnionClosed)

289289 else if Map.member name aliases then

290− Result.ok (Dups.info name region () Can.ExportAlias)

290+ Result.ok (Dups.one name region () Can.ExportAlias)

291291 else

292292 Result.throw region $ Error.ExportNotFound Error.BadType name $

293293 Map.keys unions ++ Map.keys aliases

src/Canonicalize/Pattern.hs+18−19

@@ -1,7 +1,7 @@

11{-# OPTIONS_GHC -Wall #-}

22module Canonicalize.Pattern

33 ( verify

4− , Bag

4+ , Bindings

55 , canonicalize

66 , canonicalizeArg

77 )

@@ -12,9 +12,7 @@ import qualified AST.Canonical as Can

1212import qualified AST.Source as Src

1313import qualified Canonicalize.Environment as Env

1414import qualified Canonicalize.Environment.Dups as Dups

15−import qualified Data.Bag as Bag

1615import qualified Data.Index as Index

17−import qualified Elm.Name as N

1816import qualified Reporting.Annotation as A

1917import qualified Reporting.Error.Canonicalize as Error

2018import qualified Reporting.Region as R

@@ -34,12 +32,12 @@ type Result i =

3432-- VERIFY NAMES

3533

3634

37−verify :: Error.DuplicatePatternContext -> Result Bag a -> Result () (a, Can.Destructors)

38−verify context (Result.Result bag warnings answer) =

35+verify :: Error.DuplicatePatternContext -> Result Bindings a -> Result () (a, Can.Destructors)

36+verify context (Result.Result bindings warnings answer) =

3937 case answer of

4038 Result.Ok value ->

4139 do let toError name () () = Error.DuplicatePattern context name

42− destructors <- Dups.detect toError (Bag.toList bag)

40+ destructors <- Dups.detect toError bindings

4341 Result.Result () warnings $ Result.Ok (value, destructors)

4442

4543 Result.Err err ->

@@ -50,7 +48,7 @@ verify context (Result.Result bag warnings answer) =

5048-- CANONICALIZE ARG

5149

5250

53−canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg

51+canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Arg

5452canonicalizeArg env index pattern =

5553 Can.Arg index <$> canonicalize env index pattern

5654

@@ -59,16 +57,16 @@ canonicalizeArg env index pattern =

5957-- CANONICALIZE

6058

6159

62−type Bag =

63− Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])

60+type Bindings =

61+ Dups.Dict () (A.Located Can.Destructor)

6462

6563

66−canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Pattern

64+canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Pattern

6765canonicalize env index pattern =

6866 process env (Can.DRoot index) pattern

6967

7068

71−process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern

69+process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bindings Can.Pattern

7270process env destructor (A.A region pattern) =

7371 A.A region <$>

7472 case pattern of

@@ -77,16 +75,16 @@ process env destructor (A.A region pattern) =

7775

7876 Src.PVar name ->

7977 Result.accumulate

80− (Bag.one (Dups.info name region () (A.A region destructor)))

78+ (Dups.one name region () (A.A region destructor))

8179 (Can.PVar name)

8280

8381 Src.PRecord fields ->

8482 let

85− fieldToInfo (A.A reg name) =

86− Dups.info name reg () (A.A reg (Can.DField name destructor))

83+ addField (A.A reg name) dict =

84+ Dups.insert name reg () (A.A reg (Can.DField name destructor)) dict

8785 in

8886 Result.accumulate

89− (Bag.fromList fieldToInfo fields)

87+ (foldr addField Dups.none fields)

9088 (Can.PRecord (map A.drop fields))

9189

9290 Src.PUnit ->

@@ -123,8 +121,9 @@ process env destructor (A.A region pattern) =

123121

124122 Src.PAlias ptrn (A.A reg name) ->

125123 do cpattern <- process env destructor ptrn

126− let info = Dups.info name reg () (A.A reg destructor)

127− Result.accumulate (Bag.one info) (Can.PAlias cpattern name)

124+ Result.accumulate

125+ (Dups.one name reg () (A.A reg destructor))

126+ (Can.PAlias cpattern name)

128127

129128 Src.PChr chr ->

130129 Result.ok (Can.PChr chr)

@@ -136,7 +135,7 @@ process env destructor (A.A region pattern) =

136135 Result.ok (Can.PInt int)

137136

138137

139−processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)

138+processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings (Maybe Can.Pattern)

140139processTuple tupleRegion env destructor extras =

141140 case extras of

142141 [] ->

@@ -150,7 +149,7 @@ processTuple tupleRegion env destructor extras =

150149 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))

151150

152151

153−processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]

152+processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings [Can.Pattern]

154153processList env destructor list =

155154 case list of

156155 [] ->