git.iko.soy/Idris-dev
on master help sign in
Merge pull request #547 from raichoo/master
8fc6d12Edwin Brady
src/IRTS/CodegenJavaScript.hs+97−22
compare with master
unifiedsplit
@@ -35,9 +35,14 @@ data JSType = JSIntTy
35 | JSForgotTy
35 | JSForgotTy
36 deriving Eq
36 deriving Eq
37
37
38+data JSInteger = JSBigZero
39+ | JSBigOne
40+ | JSBigInt Integer
41+ deriving Eq
42+
38data JSNum = JSInt Int
43data JSNum = JSInt Int
39 | JSFloat Double
44 | JSFloat Double
40− | JSInteger Integer
45+ | JSInteger JSInteger
41 deriving Eq
46 deriving Eq
42
47
43data JS = JSRaw String
48data JS = JSRaw String
@@ -149,9 +154,11 @@ compileJS (JSString str) =
149 show str
154 show str
150
155
151compileJS (JSNum num)
156compileJS (JSNum num)
152− | JSInt i <- num = show i
157+ | JSInt i <- num = show i
153− | JSFloat f <- num = show f
158+ | JSFloat f <- num = show f
159+ | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
160+ | JSInteger JSBigOne <- num = "__IDRRT__ONE"
154− | JSInteger i <- num = show i
161+ | JSInteger (JSBigInt i) <- num = show i
155
162
156compileJS (JSAssign lhs rhs) =
163compileJS (JSAssign lhs rhs) =
157 compileJS lhs ++ "=" ++ compileJS rhs
164 compileJS lhs ++ "=" ++ compileJS rhs
@@ -211,8 +218,8 @@ jsTypeTag :: JS -> JS
211jsTypeTag obj = JSProj obj "type"
218jsTypeTag obj = JSProj obj "type"
212
219
213jsBigInt :: JS -> JS
220jsBigInt :: JS -> JS
214−jsBigInt (JSString "0") = JSIdent "__IDRRT__ZERO"
221+jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
215−jsBigInt (JSString "1") = JSIdent "__IDRRT__ONE"
222+jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
216jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
223jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
217
224
218jsVar :: Int -> String
225jsVar :: Int -> String
@@ -229,9 +236,11 @@ jsLet name value body =
229jsSubst :: String -> JS -> JS -> JS
236jsSubst :: String -> JS -> JS -> JS
230jsSubst var new (JSVar old)
237jsSubst var new (JSVar old)
231 | var == translateVariableName old = new
238 | var == translateVariableName old = new
239+ | otherwise = JSVar old
232
240
233jsSubst var new (JSIdent old)
241jsSubst var new (JSIdent old)
234 | var == old = new
242 | var == old = new
243+ | otherwise = JSIdent old
235
244
236jsSubst var new (JSArray fields) =
245jsSubst var new (JSArray fields) =
237 JSArray (map (jsSubst var new) fields)
246 JSArray (map (jsSubst var new) fields)
@@ -241,25 +250,47 @@ jsSubst var new (JSNew con [tag, vals]) =
241
250
242jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
251jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
243 JSNew con [JSFunction [] (
252 JSNew con [JSFunction [] (
244− JSReturn $ JSApp fun (map (jsSubst var new) vars)
253+ JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars)
245 )]
254 )]
246
255
247jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
256jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
248 JSReturn (JSApp fun args)
257 JSReturn (JSApp fun args)
249 )]) =
258 )]) =
250 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
259 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
251− JSReturn $ JSApp fun (map (jsSubst var new) args)
260+ JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
252 )]
261 )]
253
262
263+jsSubst var new (JSApp (JSProj obj field) args) =
264+ JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
265+
254jsSubst var new (JSApp (JSFunction [arg] body) vals)
266jsSubst var new (JSApp (JSFunction [arg] body) vals)
255 | var /= arg =
267 | var /= arg =
256 JSApp (JSFunction [arg] (
268 JSApp (JSFunction [arg] (
257 jsSubst var new body
269 jsSubst var new body
258 )) $ map (jsSubst var new) vals
270 )) $ map (jsSubst var new) vals
271+ | otherwise =
272+ JSApp (JSFunction [arg] (
273+ body
274+ )) $ map (jsSubst var new) vals
259
275
260jsSubst var new (JSReturn ret) =
276jsSubst var new (JSReturn ret) =
261 JSReturn $ jsSubst var new ret
277 JSReturn $ jsSubst var new ret
262
278
279+jsSubst var new (JSProj obj field) =
280+ JSProj (jsSubst var new obj) field
281+
282+jsSubst var new (JSSeq body) =
283+ JSSeq $ map (jsSubst var new) body
284+
285+jsSubst var new (JSOp op lhs rhs) =
286+ JSOp op (jsSubst var new lhs) (jsSubst var new rhs)
287+
288+jsSubst var new (JSIndex obj field) =
289+ JSIndex (jsSubst var new obj) (jsSubst var new field)
290+
291+jsSubst var new (JSCond conds) =
292+ JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
293+
263jsSubst _ _ js = js
294jsSubst _ _ js = js
264
295
265inlineJS :: JS -> JS
296inlineJS :: JS -> JS
@@ -274,16 +305,12 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
274 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
305 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
275 , opt <- inlineJS val =
306 , opt <- inlineJS val =
276 JSNew con [JSFunction [] (
307 JSNew con [JSFunction [] (
277− JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
308+ JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
278 )]
309 )]
279
310
280− | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
311+ | JSApp (JSProj obj field) args <- ret
281− JSReturn (JSApp fun args)
282− )] <- ret
283 , opt <- inlineJS val =
312 , opt <- inlineJS val =
284− JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
285− JSReturn $ JSApp fun (map (jsSubst arg opt) args)
313+ JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
286− )]
287
314
288 | JSIndex (JSProj obj field) idx <- ret
315 | JSIndex (JSProj obj field) idx <- ret
289 , opt <- inlineJS val =
316 , opt <- inlineJS val =
@@ -292,9 +319,18 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
292 ) field
319 ) field
293 ) (jsSubst arg opt idx)
320 ) (jsSubst arg opt idx)
294
321
295− | JSOp op lhs rhs <- ret =
322+ | JSOp op lhs rhs <- ret
323+ , opt <- inlineJS val =
296− JSOp op (jsSubst arg (inlineJS val) lhs) $
324+ JSOp op (jsSubst arg opt lhs) $
325+ (jsSubst arg opt rhs)
326+
327+ | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
328+ JSReturn (JSApp fun args)
329+ )] <- ret
297− (jsSubst arg (inlineJS val) rhs)
330+ , opt <- inlineJS val =
331+ JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
332+ JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
333+ )]
298
334
299inlineJS (JSApp fun args) =
335inlineJS (JSApp fun args) =
300 JSApp (inlineJS fun) (map inlineJS args)
336 JSApp (inlineJS fun) (map inlineJS args)
@@ -306,7 +342,7 @@ inlineJS (JSArray fields) =
306 JSArray (map inlineJS fields)
342 JSArray (map inlineJS fields)
307
343
308inlineJS (JSAssign lhs rhs) =
344inlineJS (JSAssign lhs rhs) =
309− JSAssign lhs (inlineJS rhs)
345+ JSAssign (inlineJS lhs) (inlineJS rhs)
310
346
311inlineJS (JSSeq seq) =
347inlineJS (JSSeq seq) =
312 JSSeq (map inlineJS seq)
348 JSSeq (map inlineJS seq)
@@ -314,8 +350,8 @@ inlineJS (JSSeq seq) =
314inlineJS (JSFunction args body) =
350inlineJS (JSFunction args body) =
315 JSFunction args (inlineJS body)
351 JSFunction args (inlineJS body)
316
352
317−inlineJS (JSProj (JSFunction args body) "apply") =
353+inlineJS (JSProj (JSFunction args body) field) =
318− JSProj (JSFunction args (inlineJS body)) "apply"
354+ JSProj (JSFunction args (inlineJS body)) field
319
355
320inlineJS (JSReturn js) =
356inlineJS (JSReturn js) =
321 JSReturn $ inlineJS js
357 JSReturn $ inlineJS js
@@ -401,6 +437,45 @@ removeIDs js =
401
437
402 removeIDCall _ js = js
438 removeIDCall _ js = js
403
439
440+reduceConstant :: JS -> JS
441+reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
442+ JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
443+ )]) = JSNum num
444+
445+reduceConstant (JSReturn ret) =
446+ JSReturn (reduceConstant ret)
447+
448+reduceConstant (JSApp fun args) =
449+ JSApp (reduceConstant fun) (map reduceConstant args)
450+
451+reduceConstant (JSArray fields) =
452+ JSArray (map reduceConstant fields)
453+
454+reduceConstant (JSAlloc name (Just val)) =
455+ JSAlloc name $ Just (reduceConstant val)
456+
457+reduceConstant (JSNew con args) =
458+ JSNew con (map reduceConstant args)
459+
460+reduceConstant (JSProj obj field) =
461+ JSProj (reduceConstant obj) field
462+
463+reduceConstant (JSCond conds) =
464+ JSCond $ map (reduceConstant *** reduceConstant) conds
465+
466+reduceConstant (JSSeq seq) =
467+ JSSeq $ map reduceConstant seq
468+
469+reduceConstant (JSFunction args body) =
470+ JSFunction args (reduceConstant body)
471+
472+reduceConstant js = js
473+
474+reduceConstants :: JS -> JS
475+reduceConstants js
476+ | ret <- reduceConstant js
477+ , ret /= js = reduceConstants ret
478+ | otherwise = js
404
479
405reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
480reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
406reduceLoop reduced (cons, program) =
481reduceLoop reduced (cons, program) =
@@ -513,7 +588,7 @@ codegenJavaScript target definitions filename outputType = do
513
588
514 functions :: [String]
589 functions :: [String]
515 functions =
590 functions =
516− map compileJS ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
591+ map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
517
592
518 mainLoop :: String
593 mainLoop :: String
519 mainLoop = compileJS $
594 mainLoop = compileJS $