git.iko.soy/elk
on f6e6aff help sign in
elk/src/Generate/JavaScript/Expression.hs
502 lines 14 kB history raw
1module Generate.JavaScript.Expression (generateDef) where
3import Control.Arrow (second)
4import Control.Monad.State (State, foldM)
5import qualified Data.List as List
6import qualified Data.Map as Map
7import Language.ECMAScript3.Syntax
9import AST.Expression.Optimized as Opt
10import qualified AST.Literal as L
11import qualified AST.Module.Name as ModuleName
12import qualified AST.Variable as Var
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.JavaScript.BuiltIn as BuiltIn
15import qualified Generate.JavaScript.Literal as Literal
16import qualified Generate.JavaScript.Variable as Var
17import qualified Optimize.DecisionTree as DT
21-- CODE CHUNKS
24data Code
25 = JsExpr (Expression ())
26 | JsBlock [Statement ()]
29jsExpr :: Expression () -> State Int Code
30jsExpr exp =
31 return (JsExpr exp)
34jsBlock :: [Statement ()] -> State Int Code
35jsBlock exp =
36 return (JsBlock exp)
39isBlock :: Code -> Bool
40isBlock code =
41 case code of
42 JsBlock _ -> True
43 JsExpr _ -> False
46toStatementList :: Code -> [Statement ()]
47toStatementList code =
48 case code of
49 JsExpr expr ->
50 [ ReturnStmt () (Just expr) ]
52 JsBlock stmts ->
53 stmts
56toStatement :: Code -> Statement ()
57toStatement code =
58 case code of
59 JsExpr expr ->
60 ReturnStmt () (Just expr)
62 JsBlock [stmt] ->
63 stmt
65 JsBlock stmts ->
66 BlockStmt () stmts
69toExpr :: Code -> Expression ()
70toExpr code =
71 case code of
72 JsExpr expr ->
73 expr
75 JsBlock stmts ->
76 function [] stmts `call` []
80-- DEFINITIONS
83generateDef :: Opt.Def -> State Int (Statement ())
84generateDef def =
85 do (_home, name, jsBody) <-
86 case def of
87 Opt.TailDef (Opt.Facts home _) name argNames body ->
88 (,,) home name <$> generateTailFunction name argNames body
90 Opt.Def (Opt.Facts home _) name body ->
91 (,,) home name <$> generateJsExpr body
93 return (Var.define name jsBody)
97-- EXPRESSIONS
100generateJsExpr :: Opt.Expr -> State Int (Expression ())
101generateJsExpr optExpr =
102 toExpr <$> generateCode optExpr
105generateCode :: Opt.Expr -> State Int Code
106generateCode expr =
107 case expr of
108 Var var ->
109 jsExpr $ Var.canonical var
111 Literal lit ->
112 jsExpr (Literal.literal lit)
114 Range lo hi ->
115 do lo' <- generateJsExpr lo
116 hi' <- generateJsExpr hi
117 jsExpr $ BuiltIn.range lo' hi'
119 Access record field ->
120 do record' <- generateJsExpr record
121 jsExpr $ DotRef () record' (var (Var.safe field))
123 Update record fields ->
124 let
125 fieldToJs (field, value) =
126 do jsValue <- generateJsExpr value
127 return (Var.safe field, jsValue)
128 in
129 do jsRecord <- generateJsExpr record
130 jsFields <- mapM fieldToJs fields
131 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
133 Record fields ->
134 let
135 toField (field, value) =
136 do jsValue <- generateJsExpr value
137 return (prop (Var.safe field), jsValue)
138 in
139 do jsFields <- mapM toField fields
140 jsExpr $ ObjectLit () jsFields
142 Binop op leftExpr rightExpr ->
143 binop op leftExpr rightExpr
145 Function args body ->
146 generateFunction args body
148 Call func args ->
149 let
150 arity = length args
151 aN = "A" ++ show arity
152 in
153 do jsFunc <- generateJsExpr func
154 jsArgs <- mapM generateJsExpr args
155 jsExpr $
156 if 2 <= arity && arity <= 9 then
157 ref aN `call` (jsFunc:jsArgs)
158 else
159 foldl1 (<|) (jsFunc:jsArgs)
161 TailCall name argNames args ->
162 let
163 reassign name tempName =
164 ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
165 in
166 do args' <- mapM generateJsExpr args
167 tempNames <- mapM (\_ -> Var.fresh) args
168 jsBlock $
169 VarDeclStmt () (zipWith varDecl tempNames args')
170 : zipWith reassign argNames tempNames
171 ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
173 Let defs body ->
174 do stmts <- mapM generateDef defs
175 code <- generateCode body
176 jsBlock (stmts ++ toStatementList code)
178 If branches finally ->
179 generateIf branches finally
181 Case exprName decider jumps ->
182 JsBlock <$> generateCase exprName decider jumps
184 ExplicitList elements ->
185 do jsElements <- mapM generateJsExpr elements
186 jsExpr $ BuiltIn.list jsElements
188 Data tag members ->
189 do jsMembers <- mapM generateJsExpr members
190 jsExpr $ ObjectLit () (ctor : fields jsMembers)
191 where
192 ctor = (prop "ctor", StringLit () tag)
193 fields =
194 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
196 DataAccess dataExpr index ->
197 do jsDataExpr <- generateJsExpr dataExpr
198 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
200 GLShader _uid src _tipe ->
201 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
203 Crash home region maybeBranchProblem ->
204 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
205 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
209-- FUNCTIONS
212generateFunction :: [String] -> Opt.Expr -> State Int Code
213generateFunction args body =
214 do code <- generateCode body
215 jsExpr (generateFunctionWithArity args code)
218generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
219generateTailFunction name args body =
220 do code <- generateCode body
221 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
222 LabelledStmt ()
223 (Id () (Var.safe name))
224 (WhileStmt () (BoolLit () True) (toStatement code))
227generateFunctionWithArity :: [String] -> Code -> Expression ()
228generateFunctionWithArity rawArgs code =
229 let
230 args = map Var.safe rawArgs
231 arity = length args
232 in
233 if 2 <= arity && arity <= 9 then
234 let
235 fN = "F" ++ show arity
236 in
237 ref fN <| function args (toStatementList code)
238 else
239 let
240 (lastArg:otherArgs) = reverse args
241 innerBody = function [lastArg] (toStatementList code)
242 in
243 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
247-- GENERATE IFS
250generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
251generateIf givenBranches givenFinally =
252 let
253 (branches, finally) =
254 crushIfs givenBranches givenFinally
256 convertBranch (condition, expr) =
257 (,) <$> generateJsExpr condition <*> generateCode expr
259 ifExpression (condition, branch) otherwise =
260 CondExpr () condition branch otherwise
262 ifStatement (condition, branch) otherwise =
263 IfStmt () condition branch otherwise
264 in
265 do jsBranches <- mapM convertBranch branches
266 jsFinally <- generateCode finally
268 if any isBlock (jsFinally : map snd jsBranches)
269 then
270 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
271 else
272 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
275crushIfs
276 :: [(Opt.Expr, Opt.Expr)]
277 -> Opt.Expr
278 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
279crushIfs branches finally =
280 crushIfsHelp [] branches finally
283crushIfsHelp
284 :: [(Opt.Expr, Opt.Expr)]
285 -> [(Opt.Expr, Opt.Expr)]
286 -> Opt.Expr
287 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
288crushIfsHelp visitedBranches unvisitedBranches finally =
289 case unvisitedBranches of
290 [] ->
291 case finally of
292 If subBranches subFinally ->
293 crushIfsHelp visitedBranches subBranches subFinally
295 _ ->
296 (reverse visitedBranches, finally)
298 (Literal (L.Boolean True), branch) : _ ->
299 crushIfsHelp visitedBranches [] branch
301 visiting : unvisited ->
302 crushIfsHelp (visiting : visitedBranches) unvisited finally
306-- CASE EXPRESSIONS
309generateCase
310 :: String
311 -> Opt.Decider Opt.Choice
312 -> [(Int, Opt.Expr)]
313 -> State Int [Statement ()]
314generateCase exprName decider jumps =
315 do labelRoot <- Var.fresh
316 decider <- generateDecider exprName labelRoot decider
317 foldM (goto labelRoot) decider jumps
321-- handle any jumps
324goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
325goto labelRoot deciderStmts (target, branch) =
326 let
327 labeledDeciderStmt =
328 LabelledStmt ()
329 (toLabel labelRoot target)
330 (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
331 in
332 do code <- generateCode branch
333 return (labeledDeciderStmt : toStatementList code)
336toLabel :: String -> Int -> Id ()
337toLabel root target =
338 Id () (root ++ "_" ++ show target)
342-- turn deciders into ifs and switches
345generateDecider
346 :: String
347 -> String
348 -> Opt.Decider Opt.Choice
349 -> State Int [Statement ()]
350generateDecider exprName labelRoot decisionTree =
351 case decisionTree of
352 Opt.Leaf (Opt.Inline branch) ->
353 toStatementList <$> generateCode branch
355 Opt.Leaf (Opt.Jump target) ->
356 return [ BreakStmt () (Just (toLabel labelRoot target)) ]
358 Opt.Chain testChain success failure ->
359 let
360 makeTest (path, test) =
361 do testExpr <- pathToTestableExpr exprName path test
362 return (InfixExpr () OpStrictEq testExpr (testToExpr test))
363 in
364 do testExprs <- mapM makeTest testChain
365 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
366 thenBranch <- generateDecider exprName labelRoot success
367 elseBranch <- generateDecider exprName labelRoot failure
368 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
370 Opt.FanOut path edges fallback ->
371 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
372 caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
373 caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
374 return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
377edgeToCaseClause
378 :: String
379 -> String
380 -> (DT.Test, Opt.Decider Opt.Choice)
381 -> State Int (CaseClause ())
382edgeToCaseClause exprName labelRoot (test, subTree) =
383 CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
386testToExpr :: DT.Test -> Expression ()
387testToExpr test =
388 case test of
389 DT.Constructor (Var.Canonical _ tag) ->
390 StringLit () tag
392 DT.Literal (L.Chr char) ->
393 StringLit () [char]
395 DT.Literal lit ->
396 Literal.literal lit
400-- work with paths
403pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
404pathToTestableExpr root path exampleTest =
405 do accessExpr <- generateJsExpr (pathToExpr root path)
406 case exampleTest of
407 DT.Constructor _ ->
408 return (DotRef () accessExpr (Id () "ctor"))
410 DT.Literal (L.Chr _) ->
411 return (DotRef () accessExpr (Id () "valueOf") `call` [])
413 DT.Literal _ ->
414 return accessExpr
417pathToExpr :: String -> DT.Path -> Opt.Expr
418pathToExpr root fullPath =
419 go (Opt.Var (Var.local root)) fullPath
420 where
421 go expr path =
422 case path of
423 DT.Position index subpath ->
424 go (Opt.DataAccess expr index) subpath
426 DT.Field field subpath ->
427 go (Opt.Access expr field) subpath
429 DT.Empty ->
430 expr
432 DT.Alias ->
433 expr
437-- BINARY OPERATORS
440binop
441 :: Var.Canonical
442 -> Opt.Expr
443 -> Opt.Expr
444 -> State Int Code
445binop func left right =
446 do jsLeft <- generateJsExpr left
447 jsRight <- generateJsExpr right
448 jsExpr (makeExpr func jsLeft jsRight)
452-- BINARY OPERATOR HELPERS
455makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
456makeExpr qualifiedOp@(Var.Canonical home op) =
457 let
458 simpleMake left right =
459 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
460 in
461 if home == Var.Module (ModuleName.inCore ["Basics"]) then
462 Map.findWithDefault simpleMake op basicOps
463 else
464 simpleMake
467basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
468basicOps =
469 Map.fromList (infixOps ++ specialOps)
472infixOps :: [(String, Expression () -> Expression () -> Expression ())]
473infixOps =
474 let
475 infixOp str op =
476 (str, InfixExpr () op)
477 in
478 [ infixOp "+" OpAdd
479 , infixOp "-" OpSub
480 , infixOp "*" OpMul
481 , infixOp "/" OpDiv
482 , infixOp "&&" OpLAnd
483 , infixOp "||" OpLOr
484 ]
487specialOps :: [(String, Expression () -> Expression () -> Expression ())]
488specialOps =
489 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
490 , (,) "==" $ \a b -> BuiltIn.eq a b
491 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
492 , (,) "<" $ cmp OpLT 0
493 , (,) ">" $ cmp OpGT 0
494 , (,) "<=" $ cmp OpLT 1
495 , (,) ">=" $ cmp OpGT (-1)
496 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
497 ]
500cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
501cmp op n a b =
502 InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)