ae8d75c · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Add SCC annotations throughout type inference

ae8d75cEvan Czaplicki9 years ago

src/Type/Solve.hs+21−19

compare with master

unifiedsplit

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

22-}

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

24generalize (TS.Pool youngRank youngInhabitants) =

25+ {-# SCC elm_compiler_type_generalize #-}

25 do youngMark <- TS.uniqueMark

26 do youngMark <- TS.uniqueMark

26 let insert dict var =

27 let insert dict var =

28+ {-# SCC elm_compiler_type_insert #-}

27 do descriptor <- UF.descriptor var

29 do descriptor <- UF.descriptor var

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

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

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

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

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

50 -- For variables with rank youngRank

52 -- For variables with rank youngRank

51 -- If rank < youngRank: register in oldPool

53 -- If rank < youngRank: register in oldPool

52 -- otherwise generalize

54 -- otherwise generalize

53− let registerIfLowerRank var = do

55+ let registerIfLowerRank var =

56+ {-# SCC elm_compiler_type_register #-}

54− isRedundant <- liftIO $ UF.redundant var

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

55− case isRedundant of

58+ case isRedundant of

56− True -> return ()

59+ True -> return ()

57− False -> do

60+ False -> do

58− desc <- liftIO $ UF.descriptor var

61+ desc <- liftIO $ UF.descriptor var

59− case _rank desc < youngRank of

62+ case _rank desc < youngRank of

60− True ->

63+ True ->

61− TS.register var >> return ()

64+ TS.register var >> return ()

62− False ->

65+ False ->

63− liftIO $ UF.setDescriptor var $ desc

66+ liftIO $ UF.setDescriptor var $ desc

64− { _rank = noRank

67+ { _rank = noRank

65− , _content = rigidify (_content desc)

68+ , _content = rigidify (_content desc)

66− }

69+ }

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

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

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

82-- move deeper into a variable.

85-- move deeper into a variable.

83adjustRank :: Int -> Int -> Int -> Variable -> IO Int

86adjustRank :: Int -> Int -> Int -> Variable -> IO Int

84adjustRank youngMark visitedMark groupRank var =

87adjustRank youngMark visitedMark groupRank var =

88+ {-# SCC elm_compiler_type_adjust #-}

85 do descriptor <- UF.descriptor var

89 do descriptor <- UF.descriptor var

86 adjustRankHelp youngMark visitedMark groupRank var descriptor

90 adjustRankHelp youngMark visitedMark groupRank var descriptor

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

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

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

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

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

95−

96− maxRank <-

97− adjustRankContent youngMark visitedMark groupRank content

99+ maxRank <- adjustRankContent youngMark visitedMark groupRank content

98−

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

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

100−

101 return maxRank

102

103 else if mark /= visitedMark then

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

151

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

153solve constraint =

154+ {-# SCC elm_compiler_type_solve #-}

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

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

155 case TS.sError state of

156 case TS.sError state of

156 [] ->

157 [] ->

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

265

266

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

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

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

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

269+ {-# SCC elm_compiler_type_occurs #-}

268 do hasOccurred <- liftIO $ occursHelp [] variable

270 do hasOccurred <- liftIO $ occursHelp [] variable

269 case hasOccurred of

271 case hasOccurred of

270 False ->

272 False ->

src/Type/State.hs+11−5

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

173{-# INLINE register #-}

174register :: Variable -> Solver Variable

175register variable =

176+ {-# SCC elm_compiler_type_register #-}

176 Solver $ \state ->

177 Solver $ \state ->

177 let

178 let

178 (Pool maxRank inhabitants) =

179 (Pool maxRank inhabitants) =

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

184{-# INLINE introduce #-}

185{-# INLINE introduce #-}

185introduce :: Variable -> Solver Variable

186introduce :: Variable -> Solver Variable

186introduce variable =

187introduce variable =

188+ {-# SCC elm_compiler_type_introduce #-}

187 Solver $ \state ->

189 Solver $ \state ->

188 let

190 let

189 (Pool maxRank inhabitants) =

191 (Pool maxRank inhabitants) =

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

199

201

200flatten :: Type -> Solver Variable

202flatten :: Type -> Solver Variable

201flatten term =

203flatten term =

204+ {-# SCC elm_compiler_type_flatten #-}

202 flattenHelp Map.empty term

205 flattenHelp Map.empty term

203

206

204

207

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

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

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

214 pool <- getPool

217 pool <- getPool

215 variable <-

218 variable <-

216− liftIO . UF.fresh $ Descriptor

219+ liftIO $ UF.fresh $ Descriptor

217 { _content = Alias name flatArgs flatVar

220 { _content = Alias name flatArgs flatVar

218 , _rank = _maxRank pool

221 , _rank = _maxRank pool

219 , _mark = noMark

222 , _mark = noMark

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

228 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

231 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

229 pool <- getPool

232 pool <- getPool

230 variable <-

233 variable <-

231− liftIO . UF.fresh $ Descriptor

234+ liftIO $ UF.fresh $ Descriptor

232 { _content = Structure variableTerm

235 { _content = Structure variableTerm

233 , _rank = _maxRank pool

236 , _rank = _maxRank pool

234 , _mark = noMark

237 , _mark = noMark

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

255

258

256makeCopy :: Int -> Variable -> Solver Variable

259makeCopy :: Int -> Variable -> Solver Variable

257makeCopy alreadyCopiedMark variable =

260makeCopy alreadyCopiedMark variable =

261+ {-# SCC elm_compiler_type_copy #-}

258 do desc <- liftIO $ UF.descriptor variable

262 do desc <- liftIO $ UF.descriptor variable

259 makeCopyHelp desc alreadyCopiedMark variable

263 makeCopyHelp desc alreadyCopiedMark variable

260

264

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

423

427

424instance Functor Solver where

428instance Functor Solver where

425 {-# INLINE fmap #-}

429 {-# INLINE fmap #-}

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

430+ fmap f (Solver solver) =

431+ Solver $ \s1 ->

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

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

428

433

429

434

430instance Applicative Solver where

435instance Applicative Solver where

431 {-# INLINE pure #-}

436 {-# INLINE pure #-}

437+ pure a =

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

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

433

439

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

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

435 Solver solverFunc <*> Solver solverValue =

441 Solver solverFunc <*> Solver solverValue =

src/Type/Unify.hs+1

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

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

24unify hint region expected actual =

25+ {-# SCC elm_compiler_type_unify #-}

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

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

26 case result of

27 case result of

27 Right () ->

28 Right () ->