3e23ef2 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Use NOINLINE values to reduce allocation of Descriptors in constraint generation

3e23ef2Evan Czaplicki9 years ago

src/Type/Constrain/Effects.hs+11−11

compare with master

unifiedsplit

@@ -10,7 +10,7 @@ import qualified AST.Variable as Var

10import qualified Reporting.Annotation as A

11import qualified Reporting.Error.Type as Error

12import Type.Constraint (Constraint(..), Scheme(Scheme))

13−import Type.Type (Variable, Type(AppN,VarN), (==>), mkVar)

13+import Type.Type (Variable, Type(AppN,VarN), (==>), mkFlexVar)

@@ -44,19 +44,19 @@ constrainHelp moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

44 router msg selfMsg =

45 AppN Var.router [ VarN msg, VarN selfMsg ]

46 in

47− do v0 <- mkVar Nothing

47+ do v0 <- mkFlexVar

48− v1 <- mkVar Nothing

48+ v1 <- mkFlexVar

49− v2 <- mkVar Nothing

49+ v2 <- mkFlexVar

51− state0 <- mkVar Nothing

51+ state0 <- mkFlexVar

52− state1 <- mkVar Nothing

52+ state1 <- mkFlexVar

53− state2 <- mkVar Nothing

53+ state2 <- mkFlexVar

55− msg1 <- mkVar Nothing

55+ msg1 <- mkFlexVar

56− msg2 <- mkVar Nothing

56+ msg2 <- mkFlexVar

58− selfMsg1 <- mkVar Nothing

58+ selfMsg1 <- mkFlexVar

59− selfMsg2 <- mkVar Nothing

59+ selfMsg2 <- mkFlexVar

61 let

62 vars =

src/Type/Constrain/Expression.hs+21−24

@@ -104,7 +104,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

104 constrainCase env region expr branches tipe

105

106 C.Ctor name exprs ->

107− do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

107+ do vars <- mapM (\_ -> mkFlexVar) exprs

108 let pairs = zip exprs (map VarN vars)

109 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

110 return $ ex vars (cs /\ CInstance region (V.toText name) ctipe)

@@ -124,11 +124,11 @@ constrain env annotatedExpr@(A.A region expression) tipe =

124

125 C.Update expr fields ->

126 exists $ \t ->

127− do oldVars <- mapM (\_ -> mkVar Nothing) fields

127+ do oldVars <- mapM (\_ -> mkFlexVar) fields

128 let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

129 cOld <- ex oldVars <$> constrain env expr (RecordN oldFields t)

130

131− newVars <- mapM (\_ -> mkVar Nothing) fields

131+ newVars <- mapM (\_ -> mkFlexVar) fields

132 let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

133 let cNew = CEqual Error.Record region (RecordN newFields t) tipe

134

@@ -137,7 +137,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

137 return $ cOld /\ ex newVars (CAnd (cNew : cs))

138

139 C.Record fields ->

140− do vars <- Monad.forM fields (\_ -> mkVar Nothing)

140+ do vars <- mapM (\_ -> mkFlexVar) fields

141 fieldCons <-

142 Monad.zipWithM

143 (constrain env)

@@ -174,7 +174,7 @@ constrainApp

174 -> Type

175 -> IO Constraint

176constrainApp env region f args tipe =

177− do funcVar <- mkVar Nothing

177+ do funcVar <- mkFlexVar

178 funcCon <- constrain env f (VarN funcVar)

179

180 (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-

@@ -210,10 +210,10 @@ argConstraints env name region totalArgs overallVar index args =

210 return ([], [], [], [], Nothing, overallVar)

211

212 expr@(A.A subregion _) : rest ->

213− do argVar <- mkVar Nothing

213+ do argVar <- mkFlexVar

214 argCon <- constrain env expr (VarN argVar)

215− argIndexVar <- mkVar Nothing

215+ argIndexVar <- mkFlexVar

216− localReturnVar <- mkVar Nothing

216+ localReturnVar <- mkFlexVar

217

218 (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-

219 argConstraints env name region totalArgs localReturnVar (index + 1) rest

@@ -258,15 +258,15 @@ constrainBinop

258 -> Type

259 -> IO Constraint

260constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

261− do leftVar <- mkVar Nothing

261+ do leftVar <- mkFlexVar

262− rightVar <- mkVar Nothing

262+ rightVar <- mkFlexVar

263

264 leftCon <- constrain env leftExpr (VarN leftVar)

265 rightCon <- constrain env rightExpr (VarN rightVar)

266

267− leftVar' <- mkVar Nothing

267+ leftVar' <- mkFlexVar

268− rightVar' <- mkVar Nothing

268+ rightVar' <- mkFlexVar

269− answerVar <- mkVar Nothing

269+ answerVar <- mkFlexVar

270

271 let opType = VarN leftVar' ==> VarN rightVar' ==> VarN answerVar

272

@@ -295,7 +295,7 @@ constrainList env region exprs tipe =

295 return $ ex vars (CAnd (exprCons ++ cons))

296 where

297 elementConstraint expr@(A.A region' _) =

298− do var <- mkVar Nothing

298+ do var <- mkFlexVar

299 con <- constrain env expr (VarN var)

300 return ( (var, region'), con )

301

@@ -328,17 +328,14 @@ constrainIf env region branches finally tipe =

328

329 return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

330 where

331− bool =

332− AppN V.bool []

333−

334 constrainCondition condition@(A.A condRegion _) =

331 constrainCondition condition@(A.A condRegion _) =

335− do condVar <- mkVar Nothing

332+ do condVar <- mkFlexVar

336 condCon <- constrain env condition (VarN condVar)

333 condCon <- constrain env condition (VarN condVar)

337 let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) bool

334 let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) bool

338 return (condVar, CAnd [ condCon, boolCon ])

335 return (condVar, CAnd [ condCon, boolCon ])

339

336

340 constrainBranch expr@(A.A branchRegion _) =

337 constrainBranch expr@(A.A branchRegion _) =

341− do branchVar <- mkVar Nothing

338+ do branchVar <- mkFlexVar

342 exprCon <- constrain env expr (VarN branchVar)

339 exprCon <- constrain env expr (VarN branchVar)

343 return

340 return

344 ( (branchVar, branchRegion)

341 ( (branchVar, branchRegion)

@@ -374,7 +371,7 @@ constrainCase

374 -> Type

371 -> Type

375 -> IO Constraint

372 -> IO Constraint

376constrainCase env region expr branches tipe =

373constrainCase env region expr branches tipe =

377− do exprVar <- mkVar Nothing

374+ do exprVar <- mkFlexVar

378 exprCon <- constrain env expr (VarN exprVar)

375 exprCon <- constrain env expr (VarN exprVar)

379

376

380 (branchInfo, branchExprCons) <-

377 (branchInfo, branchExprCons) <-

@@ -385,7 +382,7 @@ constrainCase env region expr branches tipe =

385 return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

382 return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

386 where

383 where

387 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

384 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

388− do branchVar <- mkVar Nothing

385+ do branchVar <- mkFlexVar

389 scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType

386 scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType

390 branchCon <- constrain env branchExpr (VarN branchVar)

387 branchCon <- constrain env branchExpr (VarN branchVar)

391 return

388 return

@@ -422,7 +419,7 @@ pairCons region pairHint varToCon items =

422 in

419 in

423 case collectPairs 2 items of

420 case collectPairs 2 items of

424 Nothing ->

421 Nothing ->

425− do var <- mkVar Nothing

422+ do var <- mkFlexVar

426 return ([var], [varToCon var])

423 return ([var], [varToCon var])

427

424

428 Just (pairs, var) ->

425 Just (pairs, var) ->

@@ -519,7 +516,7 @@ constrainUnannotatedDef

519 -> Info

516 -> Info

520 -> IO Info

517 -> IO Info

521constrainUnannotatedDef env patternRegion name expr info =

518constrainUnannotatedDef env patternRegion name expr info =

522− do v <- mkVar Nothing

519+ do v <- mkFlexVar

523 let tipe = VarN v

520 let tipe = VarN v

524 defCon <- constrain env expr tipe

521 defCon <- constrain env expr tipe

525 return $ info

522 return $ info

@@ -592,7 +589,7 @@ constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =

592 (Pattern.Info headers argVars argCons) <-

589 (Pattern.Info headers argVars argCons) <-

593 Pattern.joinInfos <$> mapM (uncurry (Pattern.constrain finalEnv)) finalArgs

590 Pattern.joinInfos <$> mapM (uncurry (Pattern.constrain finalEnv)) finalArgs

594

591

595− resultVar <- mkVar Nothing

592+ resultVar <- mkFlexVar

596 let resultType = VarN resultVar

593 let resultType = VarN resultVar

597 defCon <- constrain finalEnv expr resultType

594 defCon <- constrain finalEnv expr resultType

598

595

src/Type/Constrain/Literal.hs+52−35

@@ -2,8 +2,7 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Type.Constrain.Literal (constrain) where

5−import qualified AST.Literal as L

5+import qualified AST.Literal as Lit

6−import qualified AST.Variable as Var

7import qualified Reporting.Error.Type as Error

6import qualified Reporting.Error.Type as Error

8import qualified Reporting.Region as R

7import qualified Reporting.Region as R

9import qualified Type.Constraint as T

8import qualified Type.Constraint as T

@@ -14,37 +13,55 @@ import qualified Type.Type as T

14-- CONSTRAIN LITERALS

13-- CONSTRAIN LITERALS

17−constrain :: R.Region -> L.Literal -> T.Type -> IO T.Constraint

16+constrain :: R.Region -> Lit.Literal -> T.Type -> IO T.Constraint

18constrain region literal tipe =

17constrain region literal tipe =

19− do definiteType <- litType

20− return (T.CEqual (Error.Literal name) region definiteType tipe)

21− where

22− prim var =

23− return (T.AppN var [])

24−

25− (name, litType) =

26− case literal of

18+ case literal of

27− L.IntNum _ ->

19+ Lit.IntNum _ ->

28− ( "number"

20+ do var <- T.mkFlexNumber

29− , T.VarN <$> T.mkVar (Just T.Number)

21+ return $ T.CEqual numberError region (T.VarN var) tipe

30− )

22+

31−

32− L.FloatNum _ ->

23+ Lit.FloatNum _ ->

33− ( "float"

24+ return $ T.CEqual floatError region T.float tipe

34− , prim Var.float

25+

35− )

36−

37− L.Chr _ ->

26+ Lit.Chr _ ->

38− ( "character"

27+ return $ T.CEqual charError region T.char tipe

39− , prim Var.char

28+

40− )

41−

42− L.Str _ ->

29+ Lit.Str _ ->

43− ( "string"

30+ return $ T.CEqual stringError region T.string tipe

44− , prim Var.string

31+

45− )

46−

47− L.Boolean _ ->

32+ Lit.Boolean _ ->

33+ return $ T.CEqual boolError region T.bool tipe

34+

35+

36+

37+-- LITERAL ERRORS

38+

39+

40+{-# NOINLINE numberError #-}

41+numberError :: Error.Hint

42+numberError =

43+ Error.Literal "number"

44+

45+

46+{-# NOINLINE floatError #-}

47+floatError :: Error.Hint

48+floatError =

49+ Error.Literal "float"

50+

51+

52+{-# NOINLINE charError #-}

53+charError :: Error.Hint

54+charError =

55+ Error.Literal "character"

56+

57+

58+{-# NOINLINE stringError #-}

59+stringError :: Error.Hint

60+stringError =

61+ Error.Literal "string"

62+

63+

64+{-# NOINLINE boolError #-}

65+boolError :: Error.Hint

66+boolError =

48− ( "boolean"

67+ Error.Literal "boolean"

49− , prim Var.bool

50− )

src/Type/Constrain/Pattern.hs+3−3

@@ -75,7 +75,7 @@ constrain env (A.A region pattern) tipe =

75 return $ emptyInfo { _cons = c }

77 P.Var name ->

78− do variable <- mkVar Nothing

78+ do variable <- mkFlexVar

79 return $ Info

80 { _headers = Map.singleton name (rvar variable)

81 , _vars = [variable]

@@ -83,7 +83,7 @@ constrain env (A.A region pattern) tipe =

83 }

85 P.Alias name ptrn ->

86− do variable <- mkVar Nothing

86+ do variable <- mkFlexVar

87 info <- constrain env ptrn tipe

88 return $ info

89 { _headers = Map.insert name (rvar variable) (_headers info)

@@ -108,7 +108,7 @@ constrain env (A.A region pattern) tipe =

108

109 P.Record fields ->

110 do pairs <-

111− mapM (\name -> (,) name <$> mkVar Nothing) fields

111+ mapM (\name -> (,) name <$> mkFlexVar) fields

112

113 let tenv =

114 Map.fromList (map (second rvar) pairs)

src/Type/Constraint.hs+3−3

@@ -15,7 +15,7 @@ import Data.Text (Text)

15import qualified Reporting.Annotation as A

16import qualified Reporting.Error.Type as Error

17import qualified Reporting.Region as R

18−import Type.Type (Type(VarN), Variable, mkVar, Super(Number))

18+import Type.Type (Type(VarN), Variable, mkFlexVar, mkFlexNumber)

@@ -84,11 +84,11 @@ forall rqs constraint =

85exists :: (Type -> IO Constraint) -> IO Constraint

86exists f =

87− do v <- mkVar Nothing

87+ do v <- mkFlexVar

88 ex [v] <$> f (VarN v)

91existsNumber :: (Type -> IO Constraint) -> IO Constraint

92existsNumber f =

93− do v <- mkVar (Just Number)

93+ do v <- mkFlexNumber

94 ex [v] <$> f (VarN v)

src/Type/Environment.hs+1−1

@@ -59,7 +59,7 @@ makeCtors unions =

60 inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator

61 inst numTVars tipe =

62− do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

62+ do vars <- mapM (\_ -> mkFlexVar) [1..numTVars]

63 let (args, result) = tipe (map (VarN) vars)

64 return (length args, vars, args, result)

src/Type/Inference.hs+1−1

@@ -62,7 +62,7 @@ genConstraints interfaces modul =

62 let header = Map.map snd (Map.fromList allTypes)

63 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

65− fvar <- T.mkVar Nothing

65+ fvar <- T.mkFlexVar

67 constraint <-

68 TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)

src/Type/Solve.hs+1−1

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

203

204 Nothing ->

205 if ModuleName.isKernel name then

206− liftIO (mkVar Nothing)

206+ liftIO mkFlexVar

207

208 else

209 error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")

src/Type/Type.hs+77−17

@@ -12,8 +12,9 @@ module Type.Type

12 , outermostRank

13 , noMark

14 , initialMark

15− , (==>)

15+ , (==>), float, char, string, bool

16− , mkVar

16+ , mkFlexVar

17+ , mkFlexNumber

17 , mkNamedVar

18 , mkNamedVar

18 , toSrcType

19 , toSrcType

19 )

20 )

@@ -78,6 +79,11 @@ data Content

78 | Error Text

79 | Error Text

82+makeDescriptor :: Content -> Descriptor

83+makeDescriptor content =

84+ Descriptor content noRank noMark Nothing

85+

86+

81data Flex

87data Flex

82 = Rigid

88 = Rigid

83 | Flex

89 | Flex

@@ -130,28 +136,79 @@ infixr 9 ==>

130 FunN

136 FunN

131

137

132

138

139+{-# NOINLINE float #-}

140+float :: Type

141+float =

142+ AppN Var.float []

133

143

134−-- VARIABLE CREATION

135

144

145+{-# NOINLINE char #-}

146+char :: Type

147+char =

148+ AppN Var.char []

136

149

137−mkDescriptor :: Content -> Descriptor

150+

138−mkDescriptor content =

151+{-# NOINLINE string #-}

139− Descriptor

152+string :: Type

140− { _content = content

153+string =

141− , _rank = noRank

154+ AppN Var.string []

142− , _mark = noMark

155+

143− , _copy = Nothing

156+

144− }

157+{-# NOINLINE bool #-}

158+bool :: Type

159+bool =

160+ AppN Var.bool []

161+

162+

163+

164+-- MAKE FLEX VARIABLES

165+

166+

167+mkFlexVar :: IO Variable

168+mkFlexVar =

169+ UF.fresh flexVarDescriptor

170+

171+

172+{-# NOINLINE flexVarDescriptor #-}

173+flexVarDescriptor :: Descriptor

174+flexVarDescriptor =

175+ makeDescriptor unnamedFlexVar

145

176

146

177

178+

179+{-# NOINLINE unnamedFlexVar #-}

180+unnamedFlexVar :: Content

181+unnamedFlexVar =

182+ Var Flex Nothing Nothing

183+

184+

185+

186+-- MAKE FLEX NUMBERS

187+

188+

147−mkVar :: Maybe Super -> IO Variable

189+mkFlexNumber :: IO Variable

148−mkVar maybeSuper =

190+mkFlexNumber =

191+ UF.fresh flexNumberDescriptor

192+

193+

194+{-# NOINLINE flexNumberDescriptor #-}

195+flexNumberDescriptor :: Descriptor

196+flexNumberDescriptor =

197+ makeDescriptor (unnamedFlexSuper Number)

198+

199+

200+unnamedFlexSuper :: Super -> Content

201+unnamedFlexSuper super =

149− UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

202+ Var Flex (Just super) Nothing

203+

204+

205+

206+-- MAKE NAMED FLEX VARIABLES

150

207

151

208

152mkNamedVar :: Flex -> Text -> IO Variable

209mkNamedVar :: Flex -> Text -> IO Variable

153mkNamedVar flex name =

210mkNamedVar flex name =

154− UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

211+ UF.fresh $ makeDescriptor $ Var flex (toSuper name) (Just name)

155

212

156

213

157toSuper :: Text -> Maybe Super

214toSuper :: Text -> Maybe Super

@@ -165,6 +222,9 @@ toSuper name =

165 else if Text.isPrefixOf "appendable" name then

222 else if Text.isPrefixOf "appendable" name then

166 Just Appendable

223 Just Appendable

167

224

225+ else if Text.isPrefixOf "compappend" name then

226+ Just CompAppend

227+

168 else

228 else

169 Nothing

229 Nothing

170

230

@@ -301,11 +361,11 @@ getFreshNormal index taken =

301 (postfix, letter) =

361 (postfix, letter) =

302 quotRem index 26

362 quotRem index 26

303

363

304− char =

364+ character =

305 Char.chr (97 + letter)

365 Char.chr (97 + letter)

306

366

307 name =

367 name =

308− Text.pack (if postfix <= 0 then [char] else char : show postfix)

368+ Text.pack (if postfix <= 0 then [character] else character : show postfix)

309 in

369 in

310 if Map.member name taken then

370 if Map.member name taken then

311 getFreshNormal (index + 1) taken

371 getFreshNormal (index + 1) taken