git.iko.soy/Idris-dev
on master help sign in
javascript: split apply function
4d2be00raichoo
jsrts/Runtime-common.js+2−6
compare with master
unifiedsplit
@@ -9,9 +9,10 @@ var i$VM = function() {
9}
9}
10
10
11/** @constructor */
11/** @constructor */
12−var i$CON = function(tag,args) {
12+var i$CON = function(tag,args,app) {
13 this.tag = tag;
13 this.tag = tag;
14 this.args = args;
14 this.args = args;
15+ this.app = app;
15}
16}
16
17
17var i$SLIDE = function(vm,args) {
18var i$SLIDE = function(vm,args) {
@@ -24,11 +25,6 @@ var i$PROJECT = function(vm,val,loc,arity) {
24 vm.valstack[vm.valstack_base + i + loc] = val.args[i];
25 vm.valstack[vm.valstack_base + i + loc] = val.args[i];
25}
26}
26
27
27−var i$RESERVE = function(vm,n) {
28− for (var i = 0; i < n; ++i)
29− vm.valstack[vm.valstack_top + i] = null;
30−}
31−
32var __IDRRT__charCode = function(str) {
28var __IDRRT__charCode = function(str) {
33 if (typeof str == "string")
29 if (typeof str == "string")
34 return str.charCodeAt(0);
30 return str.charCodeAt(0);
src/IRTS/CodegenJavaScript.hs+169−74
@@ -27,6 +27,29 @@ idrRTNamespace = "__IDRRT__"
27idrLTNamespace = "__IDRLT__"
27idrLTNamespace = "__IDRLT__"
28idrCTRNamespace = "__IDRCTR__"
28idrCTRNamespace = "__IDRCTR__"
29
29
30+data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
31+ , compileInfoEvalCases :: [Int]
32+ }
33+
34+
35+initCompileInfo :: [(Name, [BC])] -> CompileInfo
36+initCompileInfo bc = CompileInfo (collectApplyCases bc) []
37+ where
38+ collectApplyCases :: [(Name, [BC])] -> [Int]
39+ collectApplyCases bc = getCases $ findApply bc
40+
41+ findApply :: [(Name, [BC])] -> [BC]
42+ findApply ((MN 0 fun, bc):_)
43+ | fun == txt "APPLY" = bc
44+ findApply (_:bc) = findApply bc
45+
46+ getCases :: [BC] -> [Int]
47+ getCases = concatMap analyze
48+ where
49+ analyze :: BC -> [Int]
50+ analyze (CASE _ _ b _) = map fst b
51+ analyze _ = []
52+
30
53
31data JSTarget = Node | JavaScript deriving Eq
54data JSTarget = Node | JavaScript deriving Eq
32
55
@@ -82,6 +105,7 @@ data JS = JSRaw String
82 | JSPostOp String JS
105 | JSPostOp String JS
83 | JSProj JS String
106 | JSProj JS String
84 | JSNull
107 | JSNull
108+ | JSUndefined
85 | JSThis
109 | JSThis
86 | JSTrue
110 | JSTrue
87 | JSFalse
111 | JSFalse
@@ -173,6 +197,9 @@ compileJS (JSProj obj field)
173compileJS JSNull =
197compileJS JSNull =
174 "null"
198 "null"
175
199
200+compileJS JSUndefined =
201+ "undefined"
202+
176compileJS JSThis =
203compileJS JSThis =
177 "this"
204 "this"
178
205
@@ -273,7 +300,9 @@ codegenJS_all
273 -> OutputType
300 -> OutputType
274 -> IO ()
301 -> IO ()
275codegenJS_all target definitions includes filename outputType = do
302codegenJS_all target definitions includes filename outputType = do
303+ let bytecode = map toBC definitions
304+ let info = initCompileInfo bytecode
276− let code = map (compileJS . translateDecl . toBC) definitions
305+ let code = concat $ map ((concatMap compileJS) . (translateDecl info)) bytecode
277 let (header, rt) = case target of
306 let (header, rt) = case target of
278 Node ->
307 Node ->
279 ("#!/usr/bin/env node\n", "-node")
308 ("#!/usr/bin/env node\n", "-node")
@@ -284,7 +313,7 @@ codegenJS_all target definitions includes filename outputType = do
284 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
313 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
285 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
314 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
286 let runtime = header ++ jsbn ++ idrRuntime ++ tgtRuntime
315 let runtime = header ++ jsbn ++ idrRuntime ++ tgtRuntime
287− writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
316+ writeFile filename $ runtime ++ code ++ main ++ invokeMain
288 setPermissions filename (emptyPermissions { readable = True
317 setPermissions filename (emptyPermissions { readable = True
289 , executable = target == Node
318 , executable = target == Node
290 , writable = True
319 , writable = True
@@ -306,13 +335,68 @@ codegenJS_all target definitions includes filename outputType = do
306 invokeMain = compileJS $ JSApp (JSIdent "main") []
335 invokeMain = compileJS $ JSApp (JSIdent "main") []
307
336
308
337
309−translateDecl :: (Name, [BC]) -> JS
338+translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
339+translateDecl info (name@(MN 0 fun), bc)
340+ | txt "APPLY" == fun =
341+ allocCaseFunctions (snd body)
342+ ++ [ JSAlloc (
343+ translateName name
344+ ) (Just $ JSFunction ["vm", "oldbase"] (
345+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
346+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON"
347+ , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [ JSIdent "vm"
348+ , JSIdent "oldbase"
349+ , JSIdent "myoldbase"
350+ ]
351+ )
352+ , ( JSNoop
353+ , JSSeq $ map (translateBC info) (defaultCase (snd body))
354+ )
355+ ]
356+ ]
357+ )
358+ )
359+ ]
360+ where
361+ body :: ([BC], [BC])
362+ body = break isCase bc
363+
364+ isCase :: BC -> Bool
365+ isCase bc
366+ | CASE _ _ _ _ <- bc = True
367+ | otherwise = False
368+
369+ defaultCase :: [BC] -> [BC]
370+ defaultCase ((CASE _ _ _ (Just d)):_) = d
371+
372+ caseReg :: [BC] -> Reg
373+ caseReg ((CASE _ r _ _):_) = r
374+
375+ allocCaseFunctions :: [BC] -> [JS]
376+ allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
377+ allocCaseFunctions _ = []
378+
379+ splitBranches :: [(Int, [BC])] -> [JS]
380+ splitBranches = map prepBranch
381+
382+ prepBranch :: (Int, [BC]) -> JS
383+ prepBranch (tag, code) =
384+ JSAlloc (
385+ translateName name ++ "$" ++ show tag
386+ ) (Just $ JSFunction ["vm", "oldbase", "myoldbase"] (
387+ JSSeq $ map (translateBC info) code
388+ )
389+ )
390+
310−translateDecl (name, bc) =
391+translateDecl info (name, bc) =
311− JSAlloc (
392+ [ JSAlloc (
312− translateName name
393+ translateName name
313− ) (Just $ JSFunction ["vm", "oldbase"] (
394+ ) (Just $ JSFunction ["vm", "oldbase"] (
314− JSSeq $ JSAlloc "myoldbase" Nothing : map translateBC bc)
395+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
396+ )
315− )
397+ )
398+ ]
399+
316
400
317translateReg :: Reg -> JS
401translateReg :: Reg -> JS
318translateReg reg
402translateReg reg
@@ -359,7 +443,7 @@ translateConstant (B16 b) = JSWord (JSWord16 b)
359translateConstant (B32 b) = JSWord (JSWord32 b)
443translateConstant (B32 b) = JSWord (JSWord32 b)
360translateConstant (B64 b) = JSWord (JSWord64 b)
444translateConstant (B64 b) = JSWord (JSWord64 b)
361translateConstant c =
445translateConstant c =
362− jsERROR $ "Unimplemented Constant: " ++ show c
446+ JSError $ "Unimplemented Constant: " ++ show c
363
447
364
448
365translateChar :: Char -> String
449translateChar :: Char -> String
@@ -395,50 +479,50 @@ translateName n = "_idris_" ++ concatMap cchar (showCG n)
395 where cchar x | isAlpha x || isDigit x = [x]
479 where cchar x | isAlpha x || isDigit x = [x]
396 | otherwise = "_" ++ show (fromEnum x) ++ "_"
480 | otherwise = "_" ++ show (fromEnum x) ++ "_"
397
481
398−jsASSIGN :: Reg -> Reg -> JS
482+jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
399−jsASSIGN r1 r2 = JSAssign (translateReg r1) (translateReg r2)
483+jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
400
484
401−jsASSIGNCONST :: Reg -> Const -> JS
485+jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
402−jsASSIGNCONST r c = JSAssign (translateReg r) (translateConstant c)
486+jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
403
487
404−jsCALL :: Name -> JS
488+jsCALL :: CompileInfo -> Name -> JS
405−jsCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
489+jsCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
406
490
407−jsTAILCALL :: Name -> JS
491+jsTAILCALL :: CompileInfo -> Name -> JS
408−jsTAILCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
492+jsTAILCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
409
493
410−jsFOREIGN :: Reg -> String -> [(FType, Reg)] -> JS
494+jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
411−jsFOREIGN reg n args =
495+jsFOREIGN _ reg n args =
412 JSAssign (
496 JSAssign (
413 translateReg reg
497 translateReg reg
414 ) (
498 ) (
415 JSApp (JSIdent n) (map (translateReg . snd) args)
499 JSApp (JSIdent n) (map (translateReg . snd) args)
416 )
500 )
417
501
418−jsREBASE :: JS
502+jsREBASE :: CompileInfo -> JS
419−jsREBASE =
503+jsREBASE _ =
420 JSAssign (
504 JSAssign (
421 JSProj (JSIdent "vm") "valstack_base"
505 JSProj (JSIdent "vm") "valstack_base"
422 ) (
506 ) (
423 JSIdent "oldbase"
507 JSIdent "oldbase"
424 )
508 )
425
509
426−jsSTOREOLD :: JS
510+jsSTOREOLD :: CompileInfo ->JS
427−jsSTOREOLD =
511+jsSTOREOLD _ =
428 JSAssign (
512 JSAssign (
429 JSIdent "myoldbase"
513 JSIdent "myoldbase"
430 ) (
514 ) (
431 JSProj (JSIdent "vm") "valstack_base"
515 JSProj (JSIdent "vm") "valstack_base"
432 )
516 )
433
517
434−jsADDTOP :: Int -> JS
518+jsADDTOP :: CompileInfo -> Int -> JS
435−jsADDTOP n
519+jsADDTOP info n
436 | 0 <- n = JSNoop
520 | 0 <- n = JSNoop
437 | otherwise =
521 | otherwise =
438 JSBinOp "+=" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
522 JSBinOp "+=" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
439
523
440−jsTOPBASE :: Int -> JS
524+jsTOPBASE :: CompileInfo -> Int -> JS
441−jsTOPBASE n
525+jsTOPBASE info n
442 | 0 <- n =
526 | 0 <- n =
443 JSAssign (
527 JSAssign (
444 JSProj (JSIdent "vm") "valstack_top"
528 JSProj (JSIdent "vm") "valstack_top"
@@ -452,8 +536,8 @@ jsTOPBASE n
452 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
536 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
453 )
537 )
454
538
455−jsBASETOP :: Int -> JS
539+jsBASETOP :: CompileInfo -> Int -> JS
456−jsBASETOP n
540+jsBASETOP info n
457 | 0 <- n =
541 | 0 <- n =
458 JSAssign (
542 JSAssign (
459 JSProj (JSIdent "vm") "valstack_base"
543 JSProj (JSIdent "vm") "valstack_base"
@@ -467,19 +551,24 @@ jsBASETOP n
467 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
551 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
468 )
552 )
469
553
470−jsNULL :: Reg -> JS
554+jsNULL :: CompileInfo -> Reg -> JS
471−jsNULL r = JSAssign (translateReg r) JSNull
555+jsNULL _ r = JSAssign (translateReg r) JSNull
472
556
473−jsERROR :: String -> JS
557+jsERROR :: CompileInfo -> String -> JS
474−jsERROR = JSError
558+jsERROR _ = JSError
475
559
476−jsSLIDE :: Int -> JS
560+jsSLIDE :: CompileInfo -> Int -> JS
477−jsSLIDE n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
561+jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
478
562
479−jsMKCON :: Reg -> Int -> [Reg] -> JS
563+jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
480−jsMKCON r t rs =
564+jsMKCON info r t rs =
481 JSAssign (translateReg r) (
565 JSAssign (translateReg r) (
566+ JSNew "i$CON" [ JSNum (JSInt t)
482− JSNew "i$CON" [JSNum (JSInt t), JSArray (map translateReg rs)]
567+ , JSArray (map translateReg rs)
568+ , if t `elem` compileInfoApplyCases info
569+ then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
570+ else JSNull
571+ ]
483 )
572 )
484
573
485jsInstanceOf :: JS -> String -> JS
574jsInstanceOf :: JS -> String -> JS
@@ -488,6 +577,9 @@ jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
488jsOr :: JS -> JS -> JS
577jsOr :: JS -> JS -> JS
489jsOr lhs rhs = JSBinOp "||" lhs rhs
578jsOr lhs rhs = JSBinOp "||" lhs rhs
490
579
580+jsAnd :: JS -> JS -> JS
581+jsAnd lhs rhs = JSBinOp "&&" lhs rhs
582+
491jsTypeOf :: JS -> JS
583jsTypeOf :: JS -> JS
492jsTypeOf js = JSPreOp "typeof " js
584jsTypeOf js = JSPreOp "typeof " js
493
585
@@ -496,6 +588,9 @@ jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
496jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
588jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
497jsEq lhs rhs = JSBinOp "==" lhs rhs
589jsEq lhs rhs = JSBinOp "==" lhs rhs
498
590
591+jsNotEq :: JS -> JS -> JS
592+jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
593+
499jsIsNumber :: JS -> JS
594jsIsNumber :: JS -> JS
500jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
595jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
501
596
@@ -528,8 +623,8 @@ jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
528jsPackSBits32 :: JS -> JS
623jsPackSBits32 :: JS -> JS
529jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
624jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
530
625
531−jsCASE :: Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
626+jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
532−jsCASE safe reg cases def =
627+jsCASE info safe reg cases def =
533 JSSwitch (tag safe $ translateReg reg) (
628 JSSwitch (tag safe $ translateReg reg) (
534 map ((JSNum . JSInt) *** prepBranch) cases
629 map ((JSNum . JSInt) *** prepBranch) cases
535 ) (fmap prepBranch def)
630 ) (fmap prepBranch def)
@@ -539,7 +634,7 @@ jsCASE safe reg cases def =
539 tag False = jsTAG
634 tag False = jsTAG
540
635
541 prepBranch :: [BC] -> JS
636 prepBranch :: [BC] -> JS
542− prepBranch bc = JSSeq $ map translateBC bc
637+ prepBranch bc = JSSeq $ map (translateBC info) bc
543
638
544 jsTAG :: JS -> JS
639 jsTAG :: JS -> JS
545 jsTAG js =
640 jsTAG js =
@@ -553,25 +648,25 @@ jsCASE safe reg cases def =
553 jsCTAG js = JSProj js "tag"
648 jsCTAG js = JSProj js "tag"
554
649
555
650
556−jsCONSTCASE :: Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
651+jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
557−jsCONSTCASE reg cases def =
652+jsCONSTCASE info reg cases def =
558 JSCond $ (
653 JSCond $ (
559 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
654 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
560 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
655 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
561 where
656 where
562 prepBranch :: [BC] -> JS
657 prepBranch :: [BC] -> JS
563− prepBranch bc = JSSeq $ map translateBC bc
658+ prepBranch bc = JSSeq $ map (translateBC info) bc
564
659
565−jsPROJECT :: Reg -> Int -> Int -> JS
660+jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
566−jsPROJECT reg loc ar =
661+jsPROJECT _ reg loc ar =
567 JSApp (JSIdent "i$PROJECT") [ JSIdent "vm"
662 JSApp (JSIdent "i$PROJECT") [ JSIdent "vm"
568 , translateReg reg
663 , translateReg reg
569 , JSNum (JSInt loc)
664 , JSNum (JSInt loc)
570 , JSNum (JSInt ar)
665 , JSNum (JSInt ar)
571 ]
666 ]
572
667
573−jsOP :: Reg -> PrimFn -> [Reg] -> JS
668+jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
574−jsOP reg op args = JSAssign (translateReg reg) jsOP'
669+jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
575 where
670 where
576 jsOP' :: JS
671 jsOP' :: JS
577 jsOP'
672 jsOP'
@@ -1177,31 +1272,31 @@ jsOP reg op args = JSAssign (translateReg reg) jsOP'
1177 jsCall :: String -> [JS] -> JS
1272 jsCall :: String -> [JS] -> JS
1178 jsCall fun args = JSApp (JSIdent fun) args
1273 jsCall fun args = JSApp (JSIdent fun) args
1179
1274
1180−jsRESERVE :: Int -> JS
1275+jsRESERVE :: CompileInfo -> Int -> JS
1181−jsRESERVE n = JSApp (JSIdent "i$RESERVE") [JSIdent "vm", JSNum $ JSInt n]
1276+jsRESERVE _ _ = JSNoop
1182−
1277+
1183−translateBC :: BC -> JS
1278+translateBC :: CompileInfo -> BC -> JS
1184−translateBC bc
1279+translateBC info bc
1185− | ASSIGN r1 r2 <- bc = jsASSIGN r1 r2
1280+ | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1186− | ASSIGNCONST r c <- bc = jsASSIGNCONST r c
1281+ | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1187− | UPDATE r1 r2 <- bc = jsASSIGN r1 r2
1282+ | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1188− | ADDTOP n <- bc = jsADDTOP n
1283+ | ADDTOP n <- bc = jsADDTOP info n
1189− | NULL r <- bc = jsNULL r
1284+ | NULL r <- bc = jsNULL info r
1190− | CALL n <- bc = jsCALL n
1285+ | CALL n <- bc = jsCALL info n
1191− | TAILCALL n <- bc = jsTAILCALL n
1286+ | TAILCALL n <- bc = jsTAILCALL info n
1192− | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN r n a
1287+ | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1193− | TOPBASE n <- bc = jsTOPBASE n
1288+ | TOPBASE n <- bc = jsTOPBASE info n
1194− | BASETOP n <- bc = jsBASETOP n
1289+ | BASETOP n <- bc = jsBASETOP info n
1195− | STOREOLD <- bc = jsSTOREOLD
1290+ | STOREOLD <- bc = jsSTOREOLD info
1196− | SLIDE n <- bc = jsSLIDE n
1291+ | SLIDE n <- bc = jsSLIDE info n
1197− | REBASE <- bc = jsREBASE
1292+ | REBASE <- bc = jsREBASE info
1198− | RESERVE n <- bc = jsRESERVE n
1293+ | RESERVE n <- bc = jsRESERVE info n
1199− | MKCON r t rs <- bc = jsMKCON r t rs
1294+ | MKCON r t rs <- bc = jsMKCON info r t rs
1200− | CASE s r c d <- bc = jsCASE s r c d
1295+ | CASE s r c d <- bc = jsCASE info s r c d
1201− | CONSTCASE r c d <- bc = jsCONSTCASE r c d
1296+ | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1202− | PROJECT r l a <- bc = jsPROJECT r l a
1297+ | PROJECT r l a <- bc = jsPROJECT info r l a
1203− | OP r o a <- bc = jsOP r o a
1298+ | OP r o a <- bc = jsOP info r o a
1204− | ERROR e <- bc = jsERROR e
1299+ | ERROR e <- bc = jsERROR info e
1205 | otherwise = JSRaw $ show bc
1300 | otherwise = JSRaw $ show bc
1206 {-| PROJECTINTO _ _ _ <- bc = undefined-}
1301 {-| PROJECTINTO _ _ _ <- bc = undefined-}
1207
1302