b02b4aa · elk · git.iko.soy

git.iko.soy/elk

Do not expose Description fields / optimize copy and flatten

Type.State.flatten now only looks up maxRank once per call, rather than once for every The changes in Type.State.copy are a bit fancier: 1. It only looks up maxRank once per call. 2. Stop using alreadyCopiedMark. This information is already captured by the _copy field. If it has (Just copyVar) it must have been copied. The _copy field goes back to Nothing in the restore call. I also hid all the Description fields, like _content and _copy. Now you just gotta pattern match on things.

commitb02b4aa87aef3bb07d1f061aba4bcc27978d588a authorEvan Czaplicki <evancz@users.noreply.github.com> dateSun 16 Jul 2017, 21:17 (9 years ago) parentdbe6c75

5 files changed+113−205

compare with master

unifiedsplit

src/Type/Occurs.hs+2−2 src/Type/Solve.hs+5−5 src/Type/State.hs+95−161 src/Type/Type.hs+1−1 src/Type/Unify.hs+10−36

src/Type/Occurs.hs+2−2

@@ -23,8 +23,8 @@ occursHelp seen var =

2323 return True

2424

2525 else

26− do desc <- UF.descriptor var

27− case _content desc of

26+ do (Descriptor content _ _ _) <- UF.descriptor var

27+ case content of

2828 Var _ _ _ ->

2929 return False

3030

src/Type/Solve.hs+5−5

@@ -199,7 +199,7 @@ actuallySolve constraint =

199199 freshCopy <-

200200 case Map.lookup name env of

201201 Just (A.A _ tipe) ->

202− TS.makeInstance tipe

202+ TS.copy tipe

203203

204204 Nothing ->

205205 if ModuleName.isKernel name then

@@ -248,8 +248,8 @@ solveScheme scheme =

248248-- Check that a variable has rank == noRank, meaning that it can be generalized.

249249isGeneric :: Variable -> TS.Solver ()

250250isGeneric var =

251− do desc <- liftIO $ UF.descriptor var

252− if _rank desc == noRank

251+ do (Descriptor _ rank _ _) <- liftIO $ UF.descriptor var

252+ if rank == noRank

253253 then return ()

254254 else crash "Unable to generalize a type variable. It is not unranked."

255255

@@ -277,7 +277,7 @@ occurs (name, A.A region variable) =

277277

278278 True ->

279279 do overallType <- liftIO $ Type.toSrcType variable

280− infiniteDescriptor <- liftIO $ UF.descriptor variable

281− liftIO $ UF.setDescriptor variable (infiniteDescriptor { _content = Error "∞" })

280+ (Descriptor _ rank mark copy) <- liftIO $ UF.descriptor variable

281+ liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)

282282 TS.addError region (Error.InfiniteType (Right name) overallType)

283283

src/Type/State.hs+95−161

@@ -16,8 +16,7 @@ module Type.State

1616 , register

1717 , introduce

1818 , flatten

19− , makeInstance

20− , makeCopy

19+ , copy

2120 )

2221 where

2322

@@ -130,6 +129,13 @@ getPool =

130129 return ( sPool state, state )

131130

132131

132+{-# INLINE getMaxRank #-}

133+getMaxRank :: Solver Int

134+getMaxRank =

135+ Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->

136+ return ( maxRank, state )

137+

138+

133139{-# INLINE getEnv #-}

134140getEnv :: Solver Env

135141getEnv =

@@ -147,23 +153,15 @@ saveLocalEnv =

147153{-# INLINE uniqueMark #-}

148154uniqueMark :: Solver Int

149155uniqueMark =

150− Solver $ \state ->

151− let

152− mark =

153− sMark state

154− in

155− return ( mark, state { sMark = mark + 1 } )

156+ Solver $ \(SS env savedEnv pool mark errors) ->

157+ return ( mark, SS env savedEnv pool (mark + 1) errors )

156158

157159

158160{-# INLINE nextRankPool #-}

159161nextRankPool :: Solver Pool

160162nextRankPool =

161− Solver $ \state ->

162− let

163− (Pool maxRank _) =

164− sPool state

165− in

166− return ( Pool (maxRank + 1) [], state )

163+ Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->

164+ return ( Pool (maxRank + 1) [], state )

167165

168166

169167

@@ -186,13 +184,10 @@ register variable =

186184introduce :: Variable -> Solver Variable

187185introduce variable =

188186 {-# SCC elm_compiler_type_introduce #-}

189− Solver $ \state ->

190− let

191− (Pool maxRank inhabitants) =

192− sPool state

193− in

194− do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })

195− return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )

187+ Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->

188+ do UF.modifyDescriptor variable $ \(Descriptor c _ m cp) -> Descriptor c maxRank m cp

189+ let newPool = Pool maxRank (variable : inhabitants)

190+ return ( variable, SS env savedEnv newPool mark errors )

196191

197192

198193

@@ -202,201 +197,140 @@ introduce variable =

202197flatten :: Type -> Solver Variable

203198flatten term =

204199 {-# SCC elm_compiler_type_flatten #-}

205− flattenHelp Map.empty term

200+ do maxRank <- getMaxRank

201+ flattenHelp maxRank Map.empty term

206202

207203

208−flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable

209−flattenHelp aliasDict termN =

204+flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable

205+flattenHelp maxRank aliasDict termN =

210206 case termN of

211207 PlaceHolder name ->

212208 return (aliasDict ! name)

213209

214210 AliasN name args realType ->

215− do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args

216− flatVar <- flattenHelp (Map.fromList flatArgs) realType

217− makeFlatType (Alias name flatArgs flatVar)

211+ do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args

212+ flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType

213+ makeFlatType maxRank (Alias name flatArgs flatVar)

218214

219215 VarN v ->

220216 return v

221217

222218 AppN name args ->

223− do flatArgs <- traverse (flattenHelp aliasDict) args

224− makeFlatType (Structure (App1 name flatArgs))

219+ do flatArgs <- traverse (flattenHelp maxRank aliasDict) args

220+ makeFlatType maxRank (Structure (App1 name flatArgs))

225221

226222 FunN a b ->

227− do flatA <- flattenHelp aliasDict a

228− flatB <- flattenHelp aliasDict b

229− makeFlatType (Structure (Fun1 flatA flatB))

223+ do flatA <- flattenHelp maxRank aliasDict a

224+ flatB <- flattenHelp maxRank aliasDict b

225+ makeFlatType maxRank (Structure (Fun1 flatA flatB))

230226

231227 EmptyRecordN ->

232− makeFlatType (Structure EmptyRecord1)

228+ makeFlatType maxRank (Structure EmptyRecord1)

233229

234230 RecordN fields ext ->

235− do flatFields <- traverse (flattenHelp aliasDict) fields

236− flatExt <- flattenHelp aliasDict ext

237− makeFlatType (Structure (Record1 flatFields flatExt))

231+ do flatFields <- traverse (flattenHelp maxRank aliasDict) fields

232+ flatExt <- flattenHelp maxRank aliasDict ext

233+ makeFlatType maxRank (Structure (Record1 flatFields flatExt))

238234

239235

240−makeFlatType :: Content -> Solver Variable

241−makeFlatType content =

242− do pool <- getPool

243− variable <- liftIO $ UF.fresh $

244− Descriptor

245− { _content = content

246− , _rank = _maxRank pool

247− , _mark = noMark

248− , _copy = Nothing

249− }

250− register variable

236+makeFlatType :: Int -> Content -> Solver Variable

237+makeFlatType maxRank content =

238+ register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))

251239

252240

253241

254−-- MAKE INSTANCE

242+-- COPY

255243

256244

257−makeInstance :: Variable -> Solver Variable

258−makeInstance var =

259− do alreadyCopiedMark <- uniqueMark

260− freshVar <- makeCopy alreadyCopiedMark var

261− _ <- restore alreadyCopiedMark var

262− return freshVar

245+copy :: Variable -> Solver Variable

246+copy var =

247+ {-# SCC elm_compiler_type_copy #-}

248+ do maxRank <- getMaxRank

249+ copyVar <- copyHelp maxRank var

250+ _ <- restore var

251+ return copyVar

263252

264253

254+copyHelp :: Int -> Variable -> Solver Variable

255+copyHelp maxRank variable =

256+ do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable

257+ case maybeCopy of

258+ Just copiedVariable ->

259+ return copiedVariable

265260

266−-- MAKE COPY

261+ Nothing ->

262+ if rank /= noRank then

263+ return variable

267264

265+ else

266+ do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing

267+ newVar <- liftIO $ UF.fresh $ mkCopyDesc content

268+ _ <- register newVar

268269

269−makeCopy :: Int -> Variable -> Solver Variable

270−makeCopy alreadyCopiedMark variable =

271− {-# SCC elm_compiler_type_copy #-}

272− do desc <- liftIO $ UF.descriptor variable

273− makeCopyHelp desc alreadyCopiedMark variable

270+ -- Link the original variable to the new variable. This lets us

271+ -- avoid making multiple copies of the variable we are instantiating.

272+ --

273+ -- Need to do this before recursively copying the content of

274+ -- the variable to avoid looping on cyclic terms.

275+ liftIO $ UF.setDescriptor variable $

276+ Descriptor content rank noMark (Just newVar)

274277

278+ -- Now we recursively copy the content of the variable.

279+ -- We have already marked the variable as copied, so we

280+ -- will not repeat this work or crawl this variable again.

281+ case content of

282+ Structure term ->

283+ do newTerm <- traverseFlatType (copyHelp maxRank) term

284+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)

275285

276−makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable

277−makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =

278− if mark == alreadyCopiedMark then

279− case copy of

280− Just copiedVariable ->

281− return copiedVariable

286+ Var Rigid maybeSuper maybeName ->

287+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName

282288

283− Nothing ->

284− error

285− "Error copying type variable. This should be impossible.\

286− \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\

287− \ with a <http://sscce.org> and information on your OS, how you installed,\

288− \ and any other configuration information that might be helpful."

289−

290− else if rank /= noRank || not (needsCopy content) then

291− return variable

292−

293− else

294− do pool <- getPool

295− newVar <-

296− liftIO $ UF.fresh $ Descriptor

297− { _content = content -- place holder!

298− , _rank = _maxRank pool

299− , _mark = noMark

300− , _copy = Nothing

301− }

302− _ <- register newVar

303−

304− -- Link the original variable to the new variable. This lets us

305− -- avoid making multiple copies of the variable we are instantiating.

306− --

307− -- Need to do this before recursively copying the content of

308− -- the variable to avoid looping on cyclic terms.

309− liftIO $ UF.modifyDescriptor variable $ \desc ->

310− desc { _mark = alreadyCopiedMark, _copy = Just newVar }

311−

312−

313− let setContent newContent =

314− liftIO $ UF.modifyDescriptor newVar $ \desc ->

315− desc { _content = newContent }

316−

317− -- Now we recursively copy the content of the variable.

318− -- We have already marked the variable as copied, so we

319− -- will not repeat this work or crawl this variable again.

320− case content of

321− Structure term ->

322− do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term

323− setContent (Structure newTerm)

324−

325− Var Rigid maybeSuper maybeName ->

326− setContent (Var Flex maybeSuper maybeName)

327−

328− Var Flex _ _ ->

329− return ()

330−

331− Alias name args realType ->

332− setContent =<< (

333− Alias name

334− <$> mapM (traverse (makeCopy alreadyCopiedMark)) args

335− <*> makeCopy alreadyCopiedMark realType

336− )

337−

338− Error _ ->

339− return ()

340−

341− return newVar

342−

343−

344−needsCopy :: Content -> Bool

345−needsCopy content =

346− case content of

347− Structure _ ->

348− True

289+ Var Flex _ _ ->

290+ return ()

349291

350− Var _ _ _ ->

351− True

292+ Alias name args realType ->

293+ do newArgs <- mapM (traverse (copyHelp maxRank)) args

294+ newRealType <- copyHelp maxRank realType

295+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)

352296

353− Alias _ _ _ ->

354− True

297+ Error _ ->

298+ return ()

355299

356− Error _ ->

357− False

300+ return newVar

358301

359302

360303

361304-- RESTORE

362305

363306

364−restore :: Int -> Variable -> Solver Variable

365−restore alreadyCopiedMark variable =

366− do desc <- liftIO $ UF.descriptor variable

367− if _mark desc /= alreadyCopiedMark

368− then

307+restore :: Variable -> Solver Variable

308+restore variable =

309+ do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable

310+ case maybeCopy of

311+ Nothing ->

369312 return variable

370313

371− else

372− do restoredContent <-

373− restoreContent alreadyCopiedMark (_content desc)

374− liftIO $ UF.setDescriptor variable $ Descriptor

375− { _content = restoredContent

376− , _rank = noRank

377− , _mark = noMark

378− , _copy = Nothing

379− }

314+ Just _ ->

315+ do restoredContent <- restoreContent content

316+ liftIO $ UF.setDescriptor variable $

317+ Descriptor restoredContent noRank noMark Nothing

380318 return variable

381319

382320

383−

384−restoreContent :: Int -> Content -> Solver Content

385−restoreContent alreadyCopiedMark content =

386− let

387− go = restore alreadyCopiedMark

388− in

321+restoreContent :: Content -> Solver Content

322+restoreContent content =

389323 case content of

390324 Structure term ->

391− Structure <$> traverseFlatType go term

325+ Structure <$> traverseFlatType restore term

392326

393327 Var _ _ _ ->

394328 return content

395329

396330 Alias name args var ->

397331 Alias name

398− <$> mapM (traverse go) args

399− <*> go var

332+ <$> mapM (traverse restore) args

333+ <*> restore var

400334

401335 Error _ ->

402336 return content

src/Type/Type.hs+1−1

@@ -4,7 +4,7 @@ module Type.Type

44 ( Variable

55 , FlatType(..)

66 , Type(..)

7− , Descriptor(..)

7+ , Descriptor(Descriptor)

88 , Content(..)

99 , Flex(..)

1010 , Super(..)

src/Type/Unify.hs+10−36

@@ -172,24 +172,14 @@ merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) co

172172mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()

173173mergeHelp var1 var2 newContent newRank =

174174 UF.union var1 var2 $

175− Descriptor

176− { _content = newContent

177− , _rank = newRank

178− , _mark = noMark

179− , _copy = Nothing

180− }

175+ Descriptor newContent newRank noMark Nothing

181176

182177

183178fresh :: Context -> Content -> Unify Variable

184−fresh (Context _ _ desc1 _ desc2) content =

179+fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

185180 do freshVariable <-

186181 liftIO $ UF.fresh $

187− Descriptor

188− { _content = content

189− , _rank = min (_rank desc1) (_rank desc2)

190− , _mark = noMark

191− , _copy = Nothing

192− }

182+ Descriptor content (min rank1 rank2) noMark Nothing

193183 lift (TS.register freshVariable)

194184

195185

@@ -214,11 +204,7 @@ subUnify context var1 var2 =

214204

215205

216206actuallyUnify :: Context -> Unify ()

217−actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

218− let

219− firstContent = _content firstDesc

220− secondContent = _content secondDesc

221− in

207+actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

222208 case firstContent of

223209 Error _ ->

224210 -- If there was an error, just pretend it is okay. This lets us avoid

@@ -443,16 +429,9 @@ comparableOccursCheck (Context _ _ _ var _) =

443429

444430unifyComparableRecursive :: Orientation -> Variable -> Unify ()

445431unifyComparableRecursive orientation var =

446− do compVar <-

447− liftIO $

448− do desc <- UF.descriptor var

449− UF.fresh $

450− Descriptor

451− { _content = Var Flex (Just Comparable) Nothing

452− , _rank = _rank desc

453− , _mark = noMark

454− , _copy = Nothing

455− }

432+ do compVar <- liftIO $

433+ do (Descriptor _ rank _ _) <- UF.descriptor var

434+ UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing

456435

457436 guardedUnify orientation compVar var

458437

@@ -464,7 +443,7 @@ collectArgs variable =

464443

465444collectArgsHelp :: [Variable] -> Variable -> IO [Variable]

466445collectArgsHelp revArgs variable =

467− do content <- getContent variable

446+ do (Descriptor content _ _ _) <- UF.descriptor variable

468447 case content of

469448 Structure (Fun1 arg returnType) ->

470449 collectArgsHelp (arg : revArgs) returnType

@@ -473,11 +452,6 @@ collectArgsHelp revArgs variable =

473452 return $ variable : revArgs

474453

475454

476−getContent :: Variable -> IO Content

477−getContent variable =

478− _content <$> UF.descriptor variable

479−

480−

481455

482456-- UNIFY ALIASES

483457

@@ -673,8 +647,8 @@ data ExtensionStructure

673647

674648gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure

675649gatherFields context fields variable =

676− do desc <- UF.descriptor variable

677− case _content desc of

650+ do (Descriptor content _ _ _) <- UF.descriptor variable

651+ case content of

678652 Structure (Record1 subFields subExt) ->

679653 gatherFields context (Map.union fields subFields) subExt

680654