3e23ef2 · elk · git.iko.soy

git.iko.soy/elk

Use NOINLINE values to reduce allocation of Descriptors in constraint generation

Create NOINLINE values for primitives Types (float, char, string, bool) Create NOINLINE for unnamedFlexDescriptor such that mkFlexVar never needs to allocate a new Descriptor.

commit3e23ef2234b698af0d8e0f1c3068ce8c136a3066 authorEvan Czaplicki <evancz@users.noreply.github.com> dateSun 16 Jul 2017, 22:34 (9 years ago) parentb02b4aa

9 files changed+170−96

compare with master

unifiedsplit

src/Type/Constrain/Effects.hs+11−11 src/Type/Constrain/Expression.hs+21−24 src/Type/Constrain/Literal.hs+52−35 src/Type/Constrain/Pattern.hs+3−3 src/Type/Constraint.hs+3−3 src/Type/Environment.hs+1−1 src/Type/Inference.hs+1−1 src/Type/Solve.hs+1−1 src/Type/Type.hs+77−17

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

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

1010import qualified Reporting.Annotation as A

1111import qualified Reporting.Error.Type as Error

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

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

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

1414

1515

1616

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

4444 router msg selfMsg =

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

4646 in

47− do v0 <- mkVar Nothing

48− v1 <- mkVar Nothing

49− v2 <- mkVar Nothing

47+ do v0 <- mkFlexVar

48+ v1 <- mkFlexVar

49+ v2 <- mkFlexVar

5050

51− state0 <- mkVar Nothing

52− state1 <- mkVar Nothing

53− state2 <- mkVar Nothing

51+ state0 <- mkFlexVar

52+ state1 <- mkFlexVar

53+ state2 <- mkFlexVar

5454

55− msg1 <- mkVar Nothing

56− msg2 <- mkVar Nothing

55+ msg1 <- mkFlexVar

56+ msg2 <- mkFlexVar

5757

58− selfMsg1 <- mkVar Nothing

59− selfMsg2 <- mkVar Nothing

58+ selfMsg1 <- mkFlexVar

59+ selfMsg2 <- mkFlexVar

6060

6161 let

6262 vars =

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

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

104104 constrainCase env region expr branches tipe

105105

106106 C.Ctor name exprs ->

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

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

108108 let pairs = zip exprs (map VarN vars)

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

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

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

124124

125125 C.Update expr fields ->

126126 exists $ \t ->

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

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

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

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

130130

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

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

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

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

134134

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

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

138138

139139 C.Record fields ->

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

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

141141 fieldCons <-

142142 Monad.zipWithM

143143 (constrain env)

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

174174 -> Type

175175 -> IO Constraint

176176constrainApp env region f args tipe =

177− do funcVar <- mkVar Nothing

177+ do funcVar <- mkFlexVar

178178 funcCon <- constrain env f (VarN funcVar)

179179

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

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

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

211211

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

213− do argVar <- mkVar Nothing

213+ do argVar <- mkFlexVar

214214 argCon <- constrain env expr (VarN argVar)

215− argIndexVar <- mkVar Nothing

216− localReturnVar <- mkVar Nothing

215+ argIndexVar <- mkFlexVar

216+ localReturnVar <- mkFlexVar

217217

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

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

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

258258 -> Type

259259 -> IO Constraint

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

261− do leftVar <- mkVar Nothing

262− rightVar <- mkVar Nothing

261+ do leftVar <- mkFlexVar

262+ rightVar <- mkFlexVar

263263

264264 leftCon <- constrain env leftExpr (VarN leftVar)

265265 rightCon <- constrain env rightExpr (VarN rightVar)

266266

267− leftVar' <- mkVar Nothing

268− rightVar' <- mkVar Nothing

269− answerVar <- mkVar Nothing

267+ leftVar' <- mkFlexVar

268+ rightVar' <- mkFlexVar

269+ answerVar <- mkFlexVar

270270

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

272272

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

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

296296 where

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

298− do var <- mkVar Nothing

298+ do var <- mkFlexVar

299299 con <- constrain env expr (VarN var)

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

301301

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

328328

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

330330 where

331− bool =

332− AppN V.bool []

333−

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

335− do condVar <- mkVar Nothing

332+ do condVar <- mkFlexVar

336333 condCon <- constrain env condition (VarN condVar)

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

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

339336

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

341− do branchVar <- mkVar Nothing

338+ do branchVar <- mkFlexVar

342339 exprCon <- constrain env expr (VarN branchVar)

343340 return

344341 ( (branchVar, branchRegion)

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

374371 -> Type

375372 -> IO Constraint

376373constrainCase env region expr branches tipe =

377− do exprVar <- mkVar Nothing

374+ do exprVar <- mkFlexVar

378375 exprCon <- constrain env expr (VarN exprVar)

379376

380377 (branchInfo, branchExprCons) <-

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

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

386383 where

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

388− do branchVar <- mkVar Nothing

385+ do branchVar <- mkFlexVar

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

390387 branchCon <- constrain env branchExpr (VarN branchVar)

391388 return

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

422419 in

423420 case collectPairs 2 items of

424421 Nothing ->

425− do var <- mkVar Nothing

422+ do var <- mkFlexVar

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

427424

428425 Just (pairs, var) ->

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

519516 -> Info

520517 -> IO Info

521518constrainUnannotatedDef env patternRegion name expr info =

522− do v <- mkVar Nothing

519+ do v <- mkFlexVar

523520 let tipe = VarN v

524521 defCon <- constrain env expr tipe

525522 return $ info

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

592589 (Pattern.Info headers argVars argCons) <-

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

594591

595− resultVar <- mkVar Nothing

592+ resultVar <- mkFlexVar

596593 let resultType = VarN resultVar

597594 defCon <- constrain finalEnv expr resultType

598595

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

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

22{-# LANGUAGE OverloadedStrings #-}

33module Type.Constrain.Literal (constrain) where

5−import qualified AST.Literal as L

6−import qualified AST.Variable as Var

5+import qualified AST.Literal as Lit

76import qualified Reporting.Error.Type as Error

87import qualified Reporting.Region as R

98import qualified Type.Constraint as T

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

1413-- CONSTRAIN LITERALS

1514

1615

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

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

1817constrain 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

27− L.IntNum _ ->

28− ( "number"

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

30− )

31−

32− L.FloatNum _ ->

33− ( "float"

34− , prim Var.float

35− )

36−

37− L.Chr _ ->

38− ( "character"

39− , prim Var.char

40− )

41−

42− L.Str _ ->

43− ( "string"

44− , prim Var.string

45− )

46−

47− L.Boolean _ ->

48− ( "boolean"

49− , prim Var.bool

50− )

18+ case literal of

19+ Lit.IntNum _ ->

20+ do var <- T.mkFlexNumber

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

22+

23+ Lit.FloatNum _ ->

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

25+

26+ Lit.Chr _ ->

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

28+

29+ Lit.Str _ ->

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

31+

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 =

67+ Error.Literal "boolean"

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

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

7575 return $ emptyInfo { _cons = c }

7676

7777 P.Var name ->

78− do variable <- mkVar Nothing

78+ do variable <- mkFlexVar

7979 return $ Info

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

8181 , _vars = [variable]

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

8383 }

8484

8585 P.Alias name ptrn ->

86− do variable <- mkVar Nothing

86+ do variable <- mkFlexVar

8787 info <- constrain env ptrn tipe

8888 return $ info

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

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

108108

109109 P.Record fields ->

110110 do pairs <-

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

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

112112

113113 let tenv =

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

src/Type/Constraint.hs+3−3

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

1515import qualified Reporting.Annotation as A

1616import qualified Reporting.Error.Type as Error

1717import qualified Reporting.Region as R

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

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

1919

2020

2121

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

8484

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

8686exists f =

87− do v <- mkVar Nothing

87+ do v <- mkFlexVar

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

8989

9090

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

9292existsNumber f =

93− do v <- mkVar (Just Number)

93+ do v <- mkFlexNumber

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

src/Type/Environment.hs+1−1

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

5959

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

6161 inst numTVars tipe =

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

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

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

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

6565

src/Type/Inference.hs+1−1

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

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

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

6464

65− fvar <- T.mkVar Nothing

65+ fvar <- T.mkFlexVar

6666

6767 constraint <-

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

src/Type/Solve.hs+1−1

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

203203

204204 Nothing ->

205205 if ModuleName.isKernel name then

206− liftIO (mkVar Nothing)

206+ liftIO mkFlexVar

207207

208208 else

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

src/Type/Type.hs+77−17

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

1212 , outermostRank

1313 , noMark

1414 , initialMark

15− , (==>)

16− , mkVar

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

16+ , mkFlexVar

17+ , mkFlexNumber

1718 , mkNamedVar

1819 , toSrcType

1920 )

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

7879 | Error Text

7980

8081

82+makeDescriptor :: Content -> Descriptor

83+makeDescriptor content =

84+ Descriptor content noRank noMark Nothing

85+

86+

8187data Flex

8288 = Rigid

8389 | Flex

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

130136 FunN

131137

132138

139+{-# NOINLINE float #-}

140+float :: Type

141+float =

142+ AppN Var.float []

133143

134−-- VARIABLE CREATION

135144

145+{-# NOINLINE char #-}

146+char :: Type

147+char =

148+ AppN Var.char []

136149

137−mkDescriptor :: Content -> Descriptor

138−mkDescriptor content =

139− Descriptor

140− { _content = content

141− , _rank = noRank

142− , _mark = noMark

143− , _copy = Nothing

144− }

150+

151+{-# NOINLINE string #-}

152+string :: Type

153+string =

154+ AppN Var.string []

155+

156+

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

145176

146177

147−mkVar :: Maybe Super -> IO Variable

148−mkVar maybeSuper =

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

178+

179+{-# NOINLINE unnamedFlexVar #-}

180+unnamedFlexVar :: Content

181+unnamedFlexVar =

182+ Var Flex Nothing Nothing

183+

184+

185+

186+-- MAKE FLEX NUMBERS

187+

188+

189+mkFlexNumber :: IO Variable

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 =

202+ Var Flex (Just super) Nothing

203+

204+

205+

206+-- MAKE NAMED FLEX VARIABLES

150207

151208

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

153210mkNamedVar flex name =

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

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

155212

156213

157214toSuper :: Text -> Maybe Super

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

165222 else if Text.isPrefixOf "appendable" name then

166223 Just Appendable

167224

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

226+ Just CompAppend

227+

168228 else

169229 Nothing

170230

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

301361 (postfix, letter) =

302362 quotRem index 26

303363

304− char =

364+ character =

305365 Char.chr (97 + letter)

306366

307367 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)

309369 in

310370 if Map.member name taken then

311371 getFreshNormal (index + 1) taken