ae8d75c · elk · git.iko.soy

git.iko.soy/elk

Add SCC annotations throughout type inference

commitae8d75caddcd44186b16fe18385c1d83ca3ce708 authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 12 May 2017, 14:03 (9 years ago) parent5a9bb97

3 files changed+33−24

compare with master

unifiedsplit

src/Type/Solve.hs+21−19 src/Type/State.hs+11−5 src/Type/Unify.hs+1

src/Type/Solve.hs+21−19

@@ -22,8 +22,10 @@ This sorts variables into the young and old pools accordingly.

2222-}

2323generalize :: TS.Pool -> TS.Solver ()

2424generalize (TS.Pool youngRank youngInhabitants) =

25+ {-# SCC elm_compiler_type_generalize #-}

2526 do youngMark <- TS.uniqueMark

2627 let insert dict var =

28+ {-# SCC elm_compiler_type_insert #-}

2729 do descriptor <- UF.descriptor var

2830 UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })

2931 return $ Map.insertWith (++) (_rank descriptor) [var] dict

@@ -50,20 +52,21 @@ generalize (TS.Pool youngRank youngInhabitants) =

5052 -- For variables with rank youngRank

5153 -- If rank < youngRank: register in oldPool

5254 -- otherwise generalize

53− let registerIfLowerRank var = do

54− isRedundant <- liftIO $ UF.redundant var

55− case isRedundant of

56− True -> return ()

57− False -> do

58− desc <- liftIO $ UF.descriptor var

59− case _rank desc < youngRank of

60− True ->

61− TS.register var >> return ()

62− False ->

63− liftIO $ UF.setDescriptor var $ desc

64− { _rank = noRank

65− , _content = rigidify (_content desc)

66− }

55+ let registerIfLowerRank var =

56+ {-# SCC elm_compiler_type_register #-}

57+ do isRedundant <- liftIO $ UF.redundant var

58+ case isRedundant of

59+ True -> return ()

60+ False -> do

61+ desc <- liftIO $ UF.descriptor var

62+ case _rank desc < youngRank of

63+ True ->

64+ TS.register var >> return ()

65+ False ->

66+ liftIO $ UF.setDescriptor var $ desc

67+ { _rank = noRank

68+ , _content = rigidify (_content desc)

69+ }

6770

6871 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

6972

@@ -82,6 +85,7 @@ rigidify content =

8285-- move deeper into a variable.

8386adjustRank :: Int -> Int -> Int -> Variable -> IO Int

8487adjustRank youngMark visitedMark groupRank var =

88+ {-# SCC elm_compiler_type_adjust #-}

8589 do descriptor <- UF.descriptor var

8690 adjustRankHelp youngMark visitedMark groupRank var descriptor

8791

@@ -92,12 +96,8 @@ adjustRankHelp youngMark visitedMark groupRank var descriptor@(Descriptor conten

9296

9397 do -- Set the variable as marked first because it may be cyclic.

9498 UF.modifyDescriptor var $ \desc -> desc { _mark = visitedMark }

95−

96− maxRank <-

97− adjustRankContent youngMark visitedMark groupRank content

98−

99+ maxRank <- adjustRankContent youngMark visitedMark groupRank content

99100 UF.modifyDescriptor var $ \desc -> desc { _rank = maxRank }

100−

101101 return maxRank

102102

103103 else if mark /= visitedMark then

@@ -151,6 +151,7 @@ adjustRankContent youngMark visitedMark groupRank content =

151151

152152solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.State

153153solve constraint =

154+ {-# SCC elm_compiler_type_solve #-}

154155 do state <- liftIO (TS.run (actuallySolve constraint))

155156 case TS.sError state of

156157 [] ->

@@ -265,6 +266,7 @@ crash msg =

265266

266267occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()

267268occurs (name, A.A region variable) =

269+ {-# SCC elm_compiler_type_occurs #-}

268270 do hasOccurred <- liftIO $ occursHelp [] variable

269271 case hasOccurred of

270272 False ->

src/Type/State.hs+11−5

@@ -173,6 +173,7 @@ nextRankPool =

173173{-# INLINE register #-}

174174register :: Variable -> Solver Variable

175175register variable =

176+ {-# SCC elm_compiler_type_register #-}

176177 Solver $ \state ->

177178 let

178179 (Pool maxRank inhabitants) =

@@ -184,6 +185,7 @@ register variable =

184185{-# INLINE introduce #-}

185186introduce :: Variable -> Solver Variable

186187introduce variable =

188+ {-# SCC elm_compiler_type_introduce #-}

187189 Solver $ \state ->

188190 let

189191 (Pool maxRank inhabitants) =

@@ -199,6 +201,7 @@ introduce variable =

199201

200202flatten :: Type -> Solver Variable

201203flatten term =

204+ {-# SCC elm_compiler_type_flatten #-}

202205 flattenHelp Map.empty term

203206

204207

@@ -213,7 +216,7 @@ flattenHelp aliasDict termN =

213216 flatVar <- flattenHelp (Map.fromList flatArgs) realType

214217 pool <- getPool

215218 variable <-

216− liftIO . UF.fresh $ Descriptor

219+ liftIO $ UF.fresh $ Descriptor

217220 { _content = Alias name flatArgs flatVar

218221 , _rank = _maxRank pool

219222 , _mark = noMark

@@ -228,7 +231,7 @@ flattenHelp aliasDict termN =

228231 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

229232 pool <- getPool

230233 variable <-

231− liftIO . UF.fresh $ Descriptor

234+ liftIO $ UF.fresh $ Descriptor

232235 { _content = Structure variableTerm

233236 , _rank = _maxRank pool

234237 , _mark = noMark

@@ -255,6 +258,7 @@ makeInstance var =

255258

256259makeCopy :: Int -> Variable -> Solver Variable

257260makeCopy alreadyCopiedMark variable =

261+ {-# SCC elm_compiler_type_copy #-}

258262 do desc <- liftIO $ UF.descriptor variable

259263 makeCopyHelp desc alreadyCopiedMark variable

260264

@@ -423,13 +427,15 @@ traverseTerm f term =

423427

424428instance Functor Solver where

425429 {-# INLINE fmap #-}

426− fmap f (Solver solver) = Solver $ \s1 ->

427− fmap (\(a, s2) -> (f a, s2)) (solver s1)

430+ fmap f (Solver solver) =

431+ Solver $ \s1 ->

432+ fmap (\(a, s2) -> (f a, s2)) (solver s1)

428433

429434

430435instance Applicative Solver where

431436 {-# INLINE pure #-}

432− pure a = Solver $ \s -> return (a, s)

437+ pure a =

438+ Solver $ \s -> return (a, s)

433439

434440 {-# INLINE (<*>) #-}

435441 Solver solverFunc <*> Solver solverValue =

src/Type/Unify.hs+1

@@ -22,6 +22,7 @@ import Type.Type as Type

2222

2323unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

2424unify hint region expected actual =

25+ {-# SCC elm_compiler_type_unify #-}

2526 do result <- runExceptT (guardedUnify ExpectedActual expected actual)

2627 case result of

2728 Right () ->