@@ -27,6 +27,29 @@ idrRTNamespace = "__IDRRT__"
2727idrLTNamespace = "__IDRLT__"
2828idrCTRNamespace = "__IDRCTR__"
2929
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+
3053
3154data JSTarget = Node | JavaScript deriving Eq
3255
@@ -82,6 +105,7 @@ data JS = JSRaw String
82105 | JSPostOp String JS
83106 | JSProj JS String
84107 | JSNull
108+ | JSUndefined
85109 | JSThis
86110 | JSTrue
87111 | JSFalse
@@ -173,6 +197,9 @@ compileJS (JSProj obj field)
173197compileJS JSNull =
174198 "null"
175199
200+compileJS JSUndefined =
201+ "undefined"
202+
176203compileJS JSThis =
177204 "this"
178205
@@ -273,7 +300,9 @@ codegenJS_all
273300 -> OutputType
274301 -> IO ()
275302codegenJS_all target definitions includes filename outputType = do
276− let code = map (compileJS . translateDecl . toBC) definitions
303+ let bytecode = map toBC definitions
304+ let info = initCompileInfo bytecode
305+ let code = concat $ map ((concatMap compileJS) . (translateDecl info)) bytecode
277306 let (header, rt) = case target of
278307 Node ->
279308 ("#!/usr/bin/env node\n", "-node")
@@ -284,7 +313,7 @@ codegenJS_all target definitions includes filename outputType = do
284313 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
285314 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
286315 let runtime = header ++ jsbn ++ idrRuntime ++ tgtRuntime
287− writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
316+ writeFile filename $ runtime ++ code ++ main ++ invokeMain
288317 setPermissions filename (emptyPermissions { readable = True
289318 , executable = target == Node
290319 , writable = True
@@ -306,13 +335,68 @@ codegenJS_all target definitions includes filename outputType = do
306335 invokeMain = compileJS $ JSApp (JSIdent "main") []
307336
308337
309−translateDecl :: (Name, [BC]) -> JS
310−translateDecl (name, bc) =
311− JSAlloc (
312− translateName name
313− ) (Just $ JSFunction ["vm", "oldbase"] (
314− JSSeq $ JSAlloc "myoldbase" Nothing : map translateBC bc)
315− )
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+
391+translateDecl info (name, bc) =
392+ [ JSAlloc (
393+ translateName name
394+ ) (Just $ JSFunction ["vm", "oldbase"] (
395+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
396+ )
397+ )
398+ ]
399+
316400
317401translateReg :: Reg -> JS
318402translateReg reg
@@ -359,7 +443,7 @@ translateConstant (B16 b) = JSWord (JSWord16 b)
359443translateConstant (B32 b) = JSWord (JSWord32 b)
360444translateConstant (B64 b) = JSWord (JSWord64 b)
361445translateConstant c =
362− jsERROR $ "Unimplemented Constant: " ++ show c
446+ JSError $ "Unimplemented Constant: " ++ show c
363447
364448
365449translateChar :: Char -> String
@@ -395,50 +479,50 @@ translateName n = "_idris_" ++ concatMap cchar (showCG n)
395479 where cchar x | isAlpha x || isDigit x = [x]
396480 | otherwise = "_" ++ show (fromEnum x) ++ "_"
397481
398−jsASSIGN :: Reg -> Reg -> JS
399−jsASSIGN r1 r2 = JSAssign (translateReg r1) (translateReg r2)
482+jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
483+jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
400484
401−jsASSIGNCONST :: Reg -> Const -> JS
402−jsASSIGNCONST r c = JSAssign (translateReg r) (translateConstant c)
485+jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
486+jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
403487
404−jsCALL :: Name -> JS
405−jsCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
488+jsCALL :: CompileInfo -> Name -> JS
489+jsCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
406490
407−jsTAILCALL :: Name -> JS
408−jsTAILCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
491+jsTAILCALL :: CompileInfo -> Name -> JS
492+jsTAILCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
409493
410−jsFOREIGN :: Reg -> String -> [(FType, Reg)] -> JS
411−jsFOREIGN reg n args =
494+jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
495+jsFOREIGN _ reg n args =
412496 JSAssign (
413497 translateReg reg
414498 ) (
415499 JSApp (JSIdent n) (map (translateReg . snd) args)
416500 )
417501
418−jsREBASE :: JS
419−jsREBASE =
502+jsREBASE :: CompileInfo -> JS
503+jsREBASE _ =
420504 JSAssign (
421505 JSProj (JSIdent "vm") "valstack_base"
422506 ) (
423507 JSIdent "oldbase"
424508 )
425509
426−jsSTOREOLD :: JS
427−jsSTOREOLD =
510+jsSTOREOLD :: CompileInfo ->JS
511+jsSTOREOLD _ =
428512 JSAssign (
429513 JSIdent "myoldbase"
430514 ) (
431515 JSProj (JSIdent "vm") "valstack_base"
432516 )
433517
434−jsADDTOP :: Int -> JS
435−jsADDTOP n
518+jsADDTOP :: CompileInfo -> Int -> JS
519+jsADDTOP info n
436520 | 0 <- n = JSNoop
437521 | otherwise =
438522 JSBinOp "+=" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
439523
440−jsTOPBASE :: Int -> JS
441−jsTOPBASE n
524+jsTOPBASE :: CompileInfo -> Int -> JS
525+jsTOPBASE info n
442526 | 0 <- n =
443527 JSAssign (
444528 JSProj (JSIdent "vm") "valstack_top"
@@ -452,8 +536,8 @@ jsTOPBASE n
452536 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
453537 )
454538
455−jsBASETOP :: Int -> JS
456−jsBASETOP n
539+jsBASETOP :: CompileInfo -> Int -> JS
540+jsBASETOP info n
457541 | 0 <- n =
458542 JSAssign (
459543 JSProj (JSIdent "vm") "valstack_base"
@@ -467,19 +551,24 @@ jsBASETOP n
467551 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
468552 )
469553
470−jsNULL :: Reg -> JS
471−jsNULL r = JSAssign (translateReg r) JSNull
554+jsNULL :: CompileInfo -> Reg -> JS
555+jsNULL _ r = JSAssign (translateReg r) JSNull
472556
473−jsERROR :: String -> JS
474−jsERROR = JSError
557+jsERROR :: CompileInfo -> String -> JS
558+jsERROR _ = JSError
475559
476−jsSLIDE :: Int -> JS
477−jsSLIDE n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
560+jsSLIDE :: CompileInfo -> Int -> JS
561+jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
478562
479−jsMKCON :: Reg -> Int -> [Reg] -> JS
480−jsMKCON r t rs =
563+jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
564+jsMKCON info r t rs =
481565 JSAssign (translateReg r) (
482− JSNew "i$CON" [JSNum (JSInt t), JSArray (map translateReg rs)]
566+ JSNew "i$CON" [ JSNum (JSInt t)
567+ , JSArray (map translateReg rs)
568+ , if t `elem` compileInfoApplyCases info
569+ then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
570+ else JSNull
571+ ]
483572 )
484573
485574jsInstanceOf :: JS -> String -> JS
@@ -488,6 +577,9 @@ jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
488577jsOr :: JS -> JS -> JS
489578jsOr lhs rhs = JSBinOp "||" lhs rhs
490579
580+jsAnd :: JS -> JS -> JS
581+jsAnd lhs rhs = JSBinOp "&&" lhs rhs
582+
491583jsTypeOf :: JS -> JS
492584jsTypeOf js = JSPreOp "typeof " js
493585
@@ -496,6 +588,9 @@ jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
496588jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
497589jsEq lhs rhs = JSBinOp "==" lhs rhs
498590
591+jsNotEq :: JS -> JS -> JS
592+jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
593+
499594jsIsNumber :: JS -> JS
500595jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
501596
@@ -528,8 +623,8 @@ jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
528623jsPackSBits32 :: JS -> JS
529624jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
530625
531−jsCASE :: Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
532−jsCASE safe reg cases def =
626+jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
627+jsCASE info safe reg cases def =
533628 JSSwitch (tag safe $ translateReg reg) (
534629 map ((JSNum . JSInt) *** prepBranch) cases
535630 ) (fmap prepBranch def)
@@ -539,7 +634,7 @@ jsCASE safe reg cases def =
539634 tag False = jsTAG
540635
541636 prepBranch :: [BC] -> JS
542− prepBranch bc = JSSeq $ map translateBC bc
637+ prepBranch bc = JSSeq $ map (translateBC info) bc
543638
544639 jsTAG :: JS -> JS
545640 jsTAG js =
@@ -553,25 +648,25 @@ jsCASE safe reg cases def =
553648 jsCTAG js = JSProj js "tag"
554649
555650
556−jsCONSTCASE :: Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
557−jsCONSTCASE reg cases def =
651+jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
652+jsCONSTCASE info reg cases def =
558653 JSCond $ (
559654 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
560655 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
561656 where
562657 prepBranch :: [BC] -> JS
563− prepBranch bc = JSSeq $ map translateBC bc
658+ prepBranch bc = JSSeq $ map (translateBC info) bc
564659
565−jsPROJECT :: Reg -> Int -> Int -> JS
566−jsPROJECT reg loc ar =
660+jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
661+jsPROJECT _ reg loc ar =
567662 JSApp (JSIdent "i$PROJECT") [ JSIdent "vm"
568663 , translateReg reg
569664 , JSNum (JSInt loc)
570665 , JSNum (JSInt ar)
571666 ]
572667
573−jsOP :: Reg -> PrimFn -> [Reg] -> JS
574−jsOP reg op args = JSAssign (translateReg reg) jsOP'
668+jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
669+jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
575670 where
576671 jsOP' :: JS
577672 jsOP'
@@ -1177,31 +1272,31 @@ jsOP reg op args = JSAssign (translateReg reg) jsOP'
11771272 jsCall :: String -> [JS] -> JS
11781273 jsCall fun args = JSApp (JSIdent fun) args
11791274
1180−jsRESERVE :: Int -> JS
1181−jsRESERVE n = JSApp (JSIdent "i$RESERVE") [JSIdent "vm", JSNum $ JSInt n]
1182−
1183−translateBC :: BC -> JS
1184−translateBC bc
1185− | ASSIGN r1 r2 <- bc = jsASSIGN r1 r2
1186− | ASSIGNCONST r c <- bc = jsASSIGNCONST r c
1187− | UPDATE r1 r2 <- bc = jsASSIGN r1 r2
1188− | ADDTOP n <- bc = jsADDTOP n
1189− | NULL r <- bc = jsNULL r
1190− | CALL n <- bc = jsCALL n
1191− | TAILCALL n <- bc = jsTAILCALL n
1192− | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN r n a
1193− | TOPBASE n <- bc = jsTOPBASE n
1194− | BASETOP n <- bc = jsBASETOP n
1195− | STOREOLD <- bc = jsSTOREOLD
1196− | SLIDE n <- bc = jsSLIDE n
1197− | REBASE <- bc = jsREBASE
1198− | RESERVE n <- bc = jsRESERVE n
1199− | MKCON r t rs <- bc = jsMKCON r t rs
1200− | CASE s r c d <- bc = jsCASE s r c d
1201− | CONSTCASE r c d <- bc = jsCONSTCASE r c d
1202− | PROJECT r l a <- bc = jsPROJECT r l a
1203− | OP r o a <- bc = jsOP r o a
1204− | ERROR e <- bc = jsERROR e
1275+jsRESERVE :: CompileInfo -> Int -> JS
1276+jsRESERVE _ _ = JSNoop
1277+
1278+translateBC :: CompileInfo -> BC -> JS
1279+translateBC info bc
1280+ | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1281+ | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1282+ | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1283+ | ADDTOP n <- bc = jsADDTOP info n
1284+ | NULL r <- bc = jsNULL info r
1285+ | CALL n <- bc = jsCALL info n
1286+ | TAILCALL n <- bc = jsTAILCALL info n
1287+ | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1288+ | TOPBASE n <- bc = jsTOPBASE info n
1289+ | BASETOP n <- bc = jsBASETOP info n
1290+ | STOREOLD <- bc = jsSTOREOLD info
1291+ | SLIDE n <- bc = jsSLIDE info n
1292+ | REBASE <- bc = jsREBASE info
1293+ | RESERVE n <- bc = jsRESERVE info n
1294+ | MKCON r t rs <- bc = jsMKCON info r t rs
1295+ | CASE s r c d <- bc = jsCASE info s r c d
1296+ | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1297+ | PROJECT r l a <- bc = jsPROJECT info r l a
1298+ | OP r o a <- bc = jsOP info r o a
1299+ | ERROR e <- bc = jsERROR info e
12051300 | otherwise = JSRaw $ show bc
12061301 {-| PROJECTINTO _ _ _ <- bc = undefined-}
12071302