93cd759 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Remove TailCallContext from JS gen code

93cd759Evan Czaplicki11 years ago

src/Generate/JavaScript.hs+49−81

compare with master

unifiedsplit

@@ -81,39 +81,35 @@ toExpr code =

81 case code of

82 JsExpr expr ->

83 expr

84+

84 JsBlock stmts ->

85 JsBlock stmts ->

85 function [] stmts `call` []

86 function [] stmts `call` []

88−-- TAIL CALL CONTEXT

89+-- DEFINITIONS

90−type TailCallContext =

91+generateDef :: Opt.Def -> State Int (Statement ())

91− Maybe (String, [String], Label)

92+generateDef def =

93+ do (home, name, jsBody) <-

94+ case def of

95+ Opt.TailDef (Opt.Facts home _) name argNames body ->

96+ (,,) home name <$> generateTailFunction name argNames body

98+ Opt.Def (Opt.Facts home _) name body ->

99+ (,,) home name <$> generateJsExpr body

100

94−type Label =

101+ return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])

95− Id ()

102

103

98-- EXPRESSIONS

104-- EXPRESSIONS

105

100−toJsExpr :: Opt.Expr -> State Int (Expression ())

101−toJsExpr =

102− exprToJsExpr Nothing

103−

104−

105−toCode :: Opt.Expr -> State Int Code

106−toCode =

107− exprToCode Nothing

108−

109−

110−exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())

106+generateJsExpr :: Opt.Expr -> State Int (Expression ())

111−exprToJsExpr tcc canonicalExpr =

107+generateJsExpr optExpr =

112− toExpr <$> exprToCode tcc canonicalExpr

108+ toExpr <$> generateCode optExpr

113

109

114

110

115−exprToCode :: TailCallContext -> Opt.Expr -> State Int Code

111+generateCode :: Opt.Expr -> State Int Code

116−exprToCode tcc expr =

112+generateCode expr =

117 case expr of

113 case expr of

118 Var var ->

114 Var var ->

119 jsExpr $ Var.canonical var

115 jsExpr $ Var.canonical var

@@ -122,28 +118,28 @@ exprToCode tcc expr =

122 jsExpr (Literal.literal lit)

118 jsExpr (Literal.literal lit)

123

119

124 Range lo hi ->

120 Range lo hi ->

125− do lo' <- toJsExpr lo

121+ do lo' <- generateJsExpr lo

126− hi' <- toJsExpr hi

122+ hi' <- generateJsExpr hi

127 jsExpr $ BuiltIn.range lo' hi'

123 jsExpr $ BuiltIn.range lo' hi'

128

124

129 Access record field ->

125 Access record field ->

130− do record' <- toJsExpr record

126+ do record' <- generateJsExpr record

131 jsExpr $ DotRef () record' (var (Var.safe field))

127 jsExpr $ DotRef () record' (var (Var.safe field))

132

128

133 Update record fields ->

129 Update record fields ->

134 let

130 let

135 fieldToJs (field, value) =

131 fieldToJs (field, value) =

136− do jsValue <- toJsExpr value

132+ do jsValue <- generateJsExpr value

137 return (Var.safe field, jsValue)

133 return (Var.safe field, jsValue)

138 in

134 in

139− do jsRecord <- toJsExpr record

135+ do jsRecord <- generateJsExpr record

140 jsFields <- mapM fieldToJs fields

136 jsFields <- mapM fieldToJs fields

141 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields

137 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields

142

138

143 Record fields ->

139 Record fields ->

144 do fields' <-

140 do fields' <-

145 forM fields $ \(field, e) ->

141 forM fields $ \(field, e) ->

146− (,) (Var.safe field) <$> toJsExpr e

142+ (,) (Var.safe field) <$> generateJsExpr e

147

143

148 let fieldMap =

144 let fieldMap =

149 List.foldl' combine Map.empty fields'

145 List.foldl' combine Map.empty fields'

@@ -171,8 +167,8 @@ exprToCode tcc expr =

171 arity = length args

167 arity = length args

172 aN = "A" ++ show arity

168 aN = "A" ++ show arity

173 in

169 in

174− do jsFunc <- toJsExpr func

170+ do jsFunc <- generateJsExpr func

175− jsArgs <- mapM toJsExpr args

171+ jsArgs <- mapM generateJsExpr args

176 jsExpr $

172 jsExpr $

177 if 2 <= arity && arity <= 9 then

173 if 2 <= arity && arity <= 9 then

178 ref aN `call` (jsFunc:jsArgs)

174 ref aN `call` (jsFunc:jsArgs)

@@ -184,7 +180,7 @@ exprToCode tcc expr =

184 reassign name tempName =

180 reassign name tempName =

185 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

181 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

186 in

182 in

187− do args' <- mapM toJsExpr args

183+ do args' <- mapM generateJsExpr args

188 tempNames <- mapM (\_ -> Var.fresh) args

184 tempNames <- mapM (\_ -> Var.fresh) args

189 jsBlock $

185 jsBlock $

190 VarDeclStmt () (zipWith varDecl tempNames args')

186 VarDeclStmt () (zipWith varDecl tempNames args')

@@ -192,20 +188,22 @@ exprToCode tcc expr =

192 ++ [ContinueStmt () (Just (Id () name))]

188 ++ [ContinueStmt () (Just (Id () name))]

193

189

194 Let defs body ->

190 Let defs body ->

195− generateLet tcc defs body

191+ do stmts <- mapM generateDef defs

192+ code <- generateCode body

193+ jsBlock (stmts ++ toStatementList code)

196

194

197 If branches finally ->

195 If branches finally ->

198− generateIf tcc branches finally

196+ generateIf branches finally

199

197

200 Case expr decisionTree branches ->

198 Case expr decisionTree branches ->

201− generateCase tcc expr decisionTree branches

199+ generateCase expr decisionTree branches

202

200

203 ExplicitList elements ->

201 ExplicitList elements ->

204− do jsElements <- mapM toJsExpr elements

202+ do jsElements <- mapM generateJsExpr elements

205 jsExpr $ BuiltIn.list jsElements

203 jsExpr $ BuiltIn.list jsElements

206

204

207 Data tag members ->

205 Data tag members ->

208− do jsMembers <- mapM toJsExpr members

206+ do jsMembers <- mapM generateJsExpr members

209 jsExpr $ ObjectLit () (ctor : fields jsMembers)

207 jsExpr $ ObjectLit () (ctor : fields jsMembers)

210 where

208 where

211 ctor = (prop "ctor", string tag)

209 ctor = (prop "ctor", string tag)

@@ -213,7 +211,7 @@ exprToCode tcc expr =

213 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

211 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

214

212

215 DataAccess dataExpr index ->

213 DataAccess dataExpr index ->

216− do jsDataExpr <- toJsExpr dataExpr

214+ do jsDataExpr <- generateJsExpr dataExpr

217 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

215 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

218

216

219 GLShader _uid src _tipe ->

217 GLShader _uid src _tipe ->

@@ -225,11 +223,11 @@ exprToCode tcc expr =

225 jsExpr (Port.inbound name portType)

223 jsExpr (Port.inbound name portType)

226

224

227 Expr.Out name expr portType ->

225 Expr.Out name expr portType ->

228− do expr' <- toJsExpr expr

226+ do expr' <- generateJsExpr expr

229 jsExpr (Port.outbound name expr' portType)

227 jsExpr (Port.outbound name expr' portType)

230

228

231 Expr.Task name expr portType ->

229 Expr.Task name expr portType ->

232− do expr' <- toJsExpr expr

230+ do expr' <- generateJsExpr expr

233 jsExpr (Port.task name expr' portType)

231 jsExpr (Port.task name expr' portType)

234

232

235 Crash ->

233 Crash ->

@@ -240,13 +238,13 @@ exprToCode tcc expr =

240

238

241generateFunction :: [String] -> Opt.Expr -> State Int Code

239generateFunction :: [String] -> Opt.Expr -> State Int Code

242generateFunction args body =

240generateFunction args body =

243− do code <- exprToCode Nothing body

241+ do code <- generateCode body

244 jsExpr (generateFunctionWithArity args code)

242 jsExpr (generateFunctionWithArity args code)

245

243

246

244

247generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())

245generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())

248generateTailFunction name args body =

246generateTailFunction name args body =

249− do code <- exprToCode Nothing body

247+ do code <- generateCode body

250 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $

248 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $

251 LabelledStmt ()

249 LabelledStmt ()

252 (Id () name)

250 (Id () name)

@@ -271,29 +269,16 @@ generateFunctionWithArity args code =

271 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

269 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

272

270

273

271

274−-- LET EXPRESSIONS

275−

276−generateLet

277− :: TailCallContext

278− -> [Opt.Def]

279− -> Opt.Expr

280− -> State Int Code

281−generateLet tcc defs body =

282− do stmts <- mapM generateDef defs

283− code <- exprToCode tcc body

284− jsBlock (stmts ++ toStatementList code)

285−

286−

287-- GENERATE IFS

272-- GENERATE IFS

288

273

289−generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

274+generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

290−generateIf tcc givenBranches givenFinally =

275+generateIf givenBranches givenFinally =

291 let

276 let

292 (branches, finally) =

277 (branches, finally) =

293 crushIfs givenBranches givenFinally

278 crushIfs givenBranches givenFinally

294

279

295 convertBranch (condition, expr) =

280 convertBranch (condition, expr) =

296− (,) <$> toJsExpr condition <*> exprToCode tcc expr

281+ (,) <$> generateJsExpr condition <*> generateCode expr

297

282

298 ifExpression (condition, branch) otherwise =

283 ifExpression (condition, branch) otherwise =

299 CondExpr () condition branch otherwise

284 CondExpr () condition branch otherwise

@@ -302,7 +287,7 @@ generateIf tcc givenBranches givenFinally =

302 IfStmt () condition branch otherwise

287 IfStmt () condition branch otherwise

303 in

288 in

304 do jsBranches <- mapM convertBranch branches

289 do jsBranches <- mapM convertBranch branches

305− jsFinally <- exprToCode tcc finally

290+ jsFinally <- generateCode finally

306

291

307 if any isBlock (jsFinally : map snd jsBranches)

292 if any isBlock (jsFinally : map snd jsBranches)

308 then

293 then

@@ -341,32 +326,15 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

341 crushIfsHelp (visiting : visitedBranches) unvisited finally

326 crushIfsHelp (visiting : visitedBranches) unvisited finally

342

327

343

328

344−

345−-- DEFINITIONS

346−

347−generateDef :: Opt.Def -> State Int (Statement ())

348−generateDef def =

349− do (home, name, jsBody) <-

350− case def of

351− Opt.TailDef (Opt.Facts home _) name argNames body ->

352− (,,) home name <$> generateTailFunction name argNames body

353−

354− Opt.Def (Opt.Facts home _) name body ->

355− (,,) home name <$> toJsExpr body

356−

357− return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])

358−

359−

360-- CASE EXPRESSIONS

329-- CASE EXPRESSIONS

361

330

362generateCase

331generateCase

363− :: TailCallContext

364− -> Opt.Expr

332+ :: Opt.Expr

365 -> PM.DecisionTree Int

333 -> PM.DecisionTree Int

366 -> Map.Map Int Opt.Expr

334 -> Map.Map Int Opt.Expr

367 -> State Int Code

335 -> State Int Code

368−generateCase tcc expr decisionTree branches =

336+generateCase expr decisionTree branches =

369− error "TODO" tcc expr decisionTree branches

337+ error "TODO" expr decisionTree branches

370

338

371

339

372-- BINARY OPERATORS

340-- BINARY OPERATORS

@@ -378,7 +346,7 @@ binop

378 -> State Int Code

346 -> State Int Code

379binop func left right

347binop func left right

380 | func == Var.Canonical Var.BuiltIn "::" =

348 | func == Var.Canonical Var.BuiltIn "::" =

381− toCode (Data "::" [left,right])

349+ generateCode (Data "::" [left,right])

382

350

383 | func == forwardCompose =

351 | func == forwardCompose =

384 compose (collectLeftAssoc forwardCompose left right)

352 compose (collectLeftAssoc forwardCompose left right)

@@ -393,8 +361,8 @@ binop func left right

393 pipe (collectRightAssoc backwardApply left right)

361 pipe (collectRightAssoc backwardApply left right)

394

362

395 | otherwise =

363 | otherwise =

396− do jsLeft <- toJsExpr left

364+ do jsLeft <- generateJsExpr left

397− jsRight <- toJsExpr right

365+ jsRight <- generateJsExpr right

398 jsExpr (makeExpr func jsLeft jsRight)

366 jsExpr (makeExpr func jsLeft jsRight)

399

367

400

368

@@ -407,13 +375,13 @@ apply arg func =

407

375

408compose :: [Opt.Expr] -> State Int Code

376compose :: [Opt.Expr] -> State Int Code

409compose functions =

377compose functions =

410− do jsFunctions <- mapM toJsExpr functions

378+ do jsFunctions <- mapM generateJsExpr functions

411 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

379 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

412

380

413

381

414pipe :: [Opt.Expr] -> State Int Code

382pipe :: [Opt.Expr] -> State Int Code

415pipe expressions =

383pipe expressions =

416− do (value:functions) <- mapM toJsExpr expressions

384+ do (value:functions) <- mapM generateJsExpr expressions

417 jsExpr $ List.foldl' apply value functions

385 jsExpr $ List.foldl' apply value functions

418

386

419

387