git.iko.soy/Idris-dev
on master help sign in
Merge pull request #893 from raichoo/javascript
02baa3aEdwin Brady
src/IRTS/CodegenJavaScript.hs+322−164
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ import Util.System
14import Control.Arrow
14import Control.Arrow
15import Control.Applicative ((<$>), (<*>), pure)
15import Control.Applicative ((<$>), (<*>), pure)
16import Data.Char
16import Data.Char
17+import Numeric
17import Data.List
18import Data.List
18import Data.Maybe
19import Data.Maybe
19import System.IO
20import System.IO
@@ -71,7 +72,6 @@ data JS = JSRaw String
71 | JSFalse
72 | JSFalse
72 | JSArray [JS]
73 | JSArray [JS]
73 | JSString String
74 | JSString String
74− | JSChar String
75 | JSNum JSNum
75 | JSNum JSNum
76 | JSAssign JS JS
76 | JSAssign JS JS
77 | JSAlloc String (Maybe JS)
77 | JSAlloc String (Maybe JS)
@@ -162,10 +162,7 @@ compileJS (JSArray elems) =
162 "[" ++ intercalate "," (map compileJS elems) ++ "]"
162 "[" ++ intercalate "," (map compileJS elems) ++ "]"
163
163
164compileJS (JSString str) =
164compileJS (JSString str) =
165− show str
165+ "\"" ++ str ++ "\""
166−
167−compileJS (JSChar chr) =
168− chr
169
166
170compileJS (JSNum num)
167compileJS (JSNum num)
171 | JSInt i <- num = show i
168 | JSInt i <- num = show i
@@ -186,8 +183,8 @@ compileJS (JSIndex lhs rhs) =
186compileJS (JSCond branches) =
183compileJS (JSCond branches) =
187 intercalate " else " $ map createIfBlock branches
184 intercalate " else " $ map createIfBlock branches
188 where
185 where
189− createIfBlock (JSTrue, e) =
186+ createIfBlock (JSNoop, e) =
190− "if (true) {\n"
187+ "{\n"
191 ++ compileJS e
188 ++ compileJS e
192 ++ ";\n}"
189 ++ ";\n}"
193 createIfBlock (cond, e) =
190 createIfBlock (cond, e) =
@@ -420,7 +417,6 @@ removeAllocations js = transformJS removeAllocations js
420isJSConstant :: JS -> Bool
417isJSConstant :: JS -> Bool
421isJSConstant js
418isJSConstant js
422 | JSString _ <- js = True
419 | JSString _ <- js = True
423− | JSChar _ <- js = True
424 | JSNum _ <- js = True
420 | JSNum _ <- js = True
425 | JSType _ <- js = True
421 | JSType _ <- js = True
426 | JSNull <- js = True
422 | JSNull <- js = True
@@ -448,82 +444,103 @@ isJSConstantConstructor constants js
448
444
449
445
450inlineJS :: JS -> JS
446inlineJS :: JS -> JS
451−inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
447+inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
452−inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
448+ where
449+ inlineJSLet :: JS -> JS
450+ inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
451+ | opt <- inlineJSLet val =
453− inlineJS $ jsSubst (JSIdent "cse") val body
452+ inlineJS $ jsSubst (JSIdent arg) opt ret
454
453
454+ inlineJSLet js = transformJS inlineJSLet js
455
455
456−inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
457− inlineJS $ JSSeq [ JSAlloc arg (Just val)
458− , cond
459− ]
460
456
457+ inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
458+ | opt <- inlineCaseMatch val =
459+ inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
460+
461+ inlineCaseMatch js = transformJS inlineCaseMatch js
462+
463+
464+ inlineApply js
465+ | JSApp (
461−inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
466+ JSProj (JSFunction args (JSReturn body)) "apply"
462− JSThis,JSProj var "vars"
467+ ) [JSThis, JSProj var "vars"] <- js =
463− ])
468+ inlineApply $ inlineApply' var args body 0
464− | var /= JSIdent "cse" =
469+ | JSReturn (JSApp (
470+ JSProj (JSFunction args body@(JSCond _)) "apply"
471+ ) [JSThis, JSProj var "vars"]) <- js =
465− inlineJS $ inlineApply args body 0
472+ inlineApply $ inlineApply' var args body 0
473+ where
474+ inlineApply' _ [] body _ = body
475+ inlineApply' var (a:as) body n =
476+ inlineApply' var as (
477+ jsSubst (JSIdent a) (
478+ JSIndex (JSProj var "vars") (JSNum (JSInt n))
479+ ) body
480+ ) (n + 1)
481+
482+ inlineApply js = transformJS inlineApply js
483+
484+
485+ inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
486+ inlineError error
487+
488+ inlineError js = transformJS inlineError js
489+
490+
491+ inlineAssign (JSAssign lhs rhs)
492+ | JSVar _ <- lhs
493+ , JSVar _ <- rhs
494+ , lhs == rhs =
495+ lhs
496+
497+ inlineAssign (JSAssign lhs rhs)
498+ | JSIdent _ <- lhs
499+ , JSIdent _ <- rhs
500+ , lhs == rhs =
501+ lhs
502+
503+ inlineAssign js = transformJS inlineAssign js
504+
505+
506+removeEval :: [JS] -> [JS]
507+removeEval js =
508+ let (ret, isReduced) = checkEval js in
509+ if isReduced
510+ then removeEvalApp ret
511+ else ret
466 where
512 where
467− inlineApply [] body _ = inlineJS body
513+ removeEvalApp js = catMaybes (map removeEvalApp' js)
468− inlineApply (a:as) body n =
514+ where
469− inlineApply as (
515+ removeEvalApp' :: JS -> Maybe JS
470− jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
516+ removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
471− ) (n + 1)
517+ removeEvalApp' js = Just $ transformJS match js
472−
518+ where
473−inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
519+ match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
474− | isJSConstant val = val
520+ match js = transformJS match js
475−
521+
476−inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
522+ removeEvalApp js = js
477− JSFunction [] (JSReturn val)
478− ])
479− | isJSConstant val = val
480−
481−inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
482− | JSNew con [tag, vals] <- ret
483− , opt <- inlineJS val =
484− inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
485−
486− | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
487− , opt <- inlineJS val =
488− inlineJS $ JSNew con [JSFunction [] (
489− JSReturn (
490− JSApp (
491− inlineJS $ jsSubst (JSIdent arg) opt fun
492− ) (
493− map (inlineJS . jsSubst (JSIdent arg) opt) vars
494− )
495− )
496− )]
497−
498− | JSApp (JSProj obj field) args <- ret
499− , opt <- inlineJS val =
500− inlineJS $ JSApp (
501− inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
502− ) (
503− map (inlineJS . jsSubst (JSIdent arg) opt) args
504− )
505
523
506− | JSIndex (JSProj obj field) idx <- ret
524+ checkEval :: [JS] -> ([JS], Bool)
507− , opt <- inlineJS val =
525+ checkEval js = foldr f ([], False) $ map checkEval' js
508− inlineJS $ JSIndex (JSProj (
526+ where
509− inlineJS $ jsSubst (JSIdent arg) opt obj
527+ f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
510− ) field
528+ f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
511− ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
529+ f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
512
530
513− | JSBinOp op lhs rhs <- ret
514− , opt <- inlineJS val =
515− inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
516− (inlineJS $ jsSubst (JSIdent arg) opt rhs)
517
531
518− | JSApp (JSIdent fun) args <- ret
532+ checkEval' :: JS -> (Maybe JS, Bool)
519− , opt <- inlineJS val =
533+ checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
520− inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
534+ JSSeq [ _
535+ , JSReturn (JSIdent "t")
536+ ]
537+ )) []))) = (Nothing, True)
521
538
522−inlineJS js = transformJS inlineJS js
539+ checkEval' js = (Just js, False)
523
540
524
541
525reduceJS :: [JS] -> [JS]
542reduceJS :: [JS] -> [JS]
526−reduceJS js = reduceLoop [] ([], js)
543+reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
527
544
528
545
529funName :: JS -> String
546funName :: JS -> String
@@ -724,14 +741,29 @@ inlineFunctions js =
724
741
725
742
726reduceContinuations :: JS -> JS
743reduceContinuations :: JS -> JS
727−reduceContinuations = transformJS reduceHelper
744+reduceContinuations = inlineTC . reduceJS
728 where
745 where
729− reduceHelper :: JS -> JS
746+ reduceJS :: JS -> JS
730− reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
747+ reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
731 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
748 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
732− )]) = js
749+ )]) = reduceJS js
750+
751+ reduceJS js = transformJS reduceJS js
752+
753+
754+ inlineTC :: JS -> JS
755+ inlineTC js
756+ | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
757+ JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
758+ JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
759+ JSReturn (JSNew "__IDRRT__Cont" _)
760+ )])
761+ )])
762+ )] <- js = inlineTC ret
763+
764+ inlineTC js = transformJS inlineTC js
765+
733
766
734− reduceHelper js = transformJS reduceHelper js
735
767
736
768
737reduceConstant :: JS -> JS
769reduceConstant :: JS -> JS
@@ -822,19 +854,16 @@ optimizeRuntimeCalls fun tc js =
822
854
823 optTC tc@"__IDRRT__APPLYTC" =
855 optTC tc@"__IDRRT__APPLYTC" =
824 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
856 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
825− JSSeq [ JSAlloc "ev" $ Just (JSApp
857+ JSSeq [ JSAlloc "ret" $ Just (
826− (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
827− )
828− , JSAlloc "ret" $ Just (
829 JSTernary (
858 JSTernary (
830− (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
859+ (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
831− (hasProp "__IDRLT__APPLY" "ev")
860+ (hasProp "__IDRLT__APPLY" "fn0")
832 ) (JSApp
861 ) (JSApp
833 (JSIndex
862 (JSIndex
834 (JSIdent "__IDRLT__APPLY")
863 (JSIdent "__IDRLT__APPLY")
835− (JSProj (JSIdent "ev") "tag")
864+ (JSProj (JSIdent "fn0") "tag")
836 )
865 )
837− [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
866+ [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
838 ) JSNull
867 ) JSNull
839 )
868 )
840 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
869 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
@@ -861,23 +890,129 @@ unfoldLookupTable input =
861 where
890 where
862 adaptRuntime :: [JS] -> [JS]
891 adaptRuntime :: [JS] -> [JS]
863 adaptRuntime =
892 adaptRuntime =
864− adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
893+ adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
865
894
866
895
867− adaptApply var = map (jsSubst (
896+ adaptApply :: [JS] -> [JS]
868− JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
897+ adaptApply js = adaptApply' [] js
898+ where
899+ adaptApply' :: [JS] -> [JS] -> [JS]
900+ adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
901+ front ++ (new:back)
902+
903+ adaptApply' front (next:back) =
904+ adaptApply' (front ++ [next]) back
905+
906+ adaptApply' front [] = front
907+
908+ new =
909+ JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
910+ JSTernary (
911+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
869− ) (JSProj (JSIdent var) "app"))
912+ (JSProj (JSIdent "mfn0") "app")
913+ ) (JSApp
914+ (JSProj (JSIdent "mfn0") "app")
915+ [JSIdent "mfn0", JSIdent "marg0"]
916+ ) JSNull
917+ )
918+ )
870
919
871
920
921+ adaptApplyTC :: [JS] -> [JS]
922+ adaptApplyTC js = adaptApplyTC' [] js
923+ where
924+ adaptApplyTC' :: [JS] -> [JS] -> [JS]
925+ adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
926+ front ++ (new:back)
927+
928+ adaptApplyTC' front (next:back) =
929+ adaptApplyTC' (front ++ [next]) back
930+
931+ adaptApplyTC' front [] = front
932+
933+ new =
934+ JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
935+ JSSeq [ JSAlloc "ret" $ Just (
936+ JSTernary (
937+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
938+ (JSProj (JSIdent "mfn0") "app")
939+ ) (JSApp
940+ (JSProj (JSIdent "mfn0") "app")
941+ [JSIdent "mfn0", JSIdent "marg0"]
942+ ) JSNull
943+ )
944+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
945+ JSAssign (JSIdent "ret") (
946+ JSApp (JSProj (JSIdent "ret") "k") []
947+ )
948+ )
949+ , JSReturn $ JSIdent "ret"
950+ ]
951+ ))
952+
953+
872− adaptEval = map (jsSubst (
954+ adaptEval :: [JS] -> [JS]
873− JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
955+ adaptEval js = adaptEval' [] js
956+ where
957+ adaptEval' :: [JS] -> [JS] -> [JS]
958+ adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
959+ front ++ (new:back)
960+
961+ adaptEval' front (next:back) =
962+ adaptEval' (front ++ [next]) back
963+
964+ adaptEval' front [] = front
965+
966+ new =
967+ JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
968+ JSTernary (
969+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
970+ (JSProj (JSIdent "marg0") "eval")
971+ ) (JSApp
972+ (JSProj (JSIdent "marg0") "eval")
973+ [JSIdent "marg0"]
974+ ) (JSIdent "marg0")
975+ )
976+ )
977+
978+
979+ adaptEvalTC :: [JS] -> [JS]
980+ adaptEvalTC js = adaptEvalTC' [] js
981+ where
982+ adaptEvalTC' :: [JS] -> [JS] -> [JS]
983+ adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
984+ front ++ (new:back)
985+
986+ adaptEvalTC' front (next:back) =
987+ adaptEvalTC' (front ++ [next]) back
988+
989+ adaptEvalTC' front [] = front
990+
991+ new =
992+ JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
993+ JSSeq [ JSAlloc "ret" $ Just (
994+ JSTernary (
995+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
874− ) (JSProj (JSIdent "arg0") "eval"))
996+ (JSProj (JSIdent "marg0") "eval")
997+ ) (JSApp
998+ (JSProj (JSIdent "marg0") "eval")
999+ [JSIdent "marg0"]
1000+ ) (JSIdent "marg0")
1001+ )
1002+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1003+ JSAssign (JSIdent "ret") (
1004+ JSApp (JSProj (JSIdent "ret") "k") []
1005+ )
1006+ )
1007+ , JSReturn $ JSIdent "ret"
1008+ ]
1009+ ))
875
1010
876
1011
877 adaptCon js =
1012 adaptCon js =
878 adaptCon' [] js
1013 adaptCon' [] js
879 where
1014 where
880− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
1015+ adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =
881 front ++ (new:back)
1016 front ++ (new:back)
882
1017
883 adaptCon' front (next:back) =
1018 adaptCon' front (next:back) =
@@ -970,8 +1105,8 @@ removeInstanceChecks (JSCond conds) =
970 removeHelper js = js
1105 removeHelper js = js
971
1106
972
1107
973− eliminateDeadBranches (e@(JSTrue, _):_) = [e]
1108+ eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
974− eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
1109+ eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
975 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1110 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
976 eliminateDeadBranches [] = []
1111 eliminateDeadBranches [] = []
977
1112
@@ -1022,15 +1157,6 @@ reduceLoop reduced (cons, program) =
1022 reduceCall funs js = transformJS (reduceCall funs) js
1157 reduceCall funs js = transformJS (reduceCall funs) js
1023
1158
1024
1159
1025−optimizeJS :: JS -> JS
1026−optimizeJS = inlineLoop
1027− where inlineLoop :: JS -> JS
1028− inlineLoop js
1029− | opt <- inlineJS js
1030− , opt /= js = inlineLoop opt
1031− | otherwise = js
1032−
1033−
1034extractLocalConstructors :: [JS] -> [JS]
1160extractLocalConstructors :: [JS] -> [JS]
1035extractLocalConstructors js =
1161extractLocalConstructors js =
1036 concatMap extractLocalConstructors' js
1162 concatMap extractLocalConstructors' js
@@ -1243,24 +1369,25 @@ codegenJavaScript target definitions filename outputType = do
1243 compile =
1369 compile =
1244 map compileJS
1370 map compileJS
1245
1371
1246− opt = []
1372+ opt =
1247− {-[ map optimizeJS-}
1373+ [ removeEval
1374+ , map inlineJS
1248− {-, removeIDs-}
1375+ , removeIDs
1249− {-, reduceJS-}
1376+ , reduceJS
1250− {-, map reduceConstants-}
1377+ , map reduceConstants
1251− {-, initConstructors-}
1378+ , initConstructors
1252− {-, map removeAllocations-}
1379+ , map removeAllocations
1253− {-, elimDeadLoop-}
1380+ , elimDeadLoop
1254− {-, map elimDuplicateEvals-}
1381+ , map elimDuplicateEvals
1255− {-, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-}
1382+ , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1256− {-, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-}
1383+ , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1257− {-, map removeInstanceChecks-}
1384+ , map removeInstanceChecks
1258− {-, inlineFunctions-}
1385+ , inlineFunctions
1259− {-, map reduceContinuations-}
1386+ , map reduceContinuations
1260− {-, extractLocalConstructors-}
1387+ , extractLocalConstructors
1261− {-, unfoldLookupTable-}
1388+ , unfoldLookupTable
1262− {-, evalCons-}
1389+ , evalCons
1263− {-]-}
1390+ ]
1264
1391
1265 prelude :: [JS]
1392 prelude :: [JS]
1266 prelude =
1393 prelude =
@@ -1400,11 +1527,8 @@ translateSpecialName name
1400translateConstant :: Const -> JS
1527translateConstant :: Const -> JS
1401translateConstant (I i) = JSNum (JSInt i)
1528translateConstant (I i) = JSNum (JSInt i)
1402translateConstant (Fl f) = JSNum (JSFloat f)
1529translateConstant (Fl f) = JSNum (JSFloat f)
1403−translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1530+translateConstant (Ch c) = JSString $ translateChar c
1404−translateConstant (Ch '\a') = JSChar "'\\u0007'"
1405−translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1406−translateConstant (Ch c) = JSString [c]
1407−translateConstant (Str s) = JSString s
1531+translateConstant (Str s) = JSString $ concatMap translateChar s
1408translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1532translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1409translateConstant StrType = JSType JSStringTy
1533translateConstant StrType = JSType JSStringTy
1410translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1534translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
@@ -1417,44 +1541,72 @@ translateConstant c =
1417 jsError $ "Unimplemented Constant: " ++ show c
1541 jsError $ "Unimplemented Constant: " ++ show c
1418
1542
1419
1543
1544+translateChar :: Char -> String
1545+translateChar ch
1546+ | '\a' <- ch = "\\u0007"
1547+ | '\b' <- ch = "\\b"
1548+ | '\f' <- ch = "\\f"
1549+ | '\n' <- ch = "\\n"
1550+ | '\r' <- ch = "\\r"
1551+ | '\t' <- ch = "\\t"
1552+ | '\v' <- ch = "\\v"
1553+ | '\SO' <- ch = "\\u000E"
1554+ | '\DEL' <- ch = "\\u007F"
1555+ | '\\' <- ch = "\\\\"
1556+ | '\"' <- ch = "\\\""
1557+ | '\'' <- ch = "\\\'"
1558+ | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1559+ | otherwise = [ch]
1560+ where
1561+ fill :: String -> String
1562+ fill s = if length s == 1
1563+ then '0' : s
1564+ else s
1565+
1566+ asciiTab =
1567+ ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1568+ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1569+ '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1570+ '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1571+
1572+
1420translateDeclaration :: (String, SDecl) -> [JS]
1573translateDeclaration :: (String, SDecl) -> [JS]
1421translateDeclaration (path, SFun name params stackSize body)
1574translateDeclaration (path, SFun name params stackSize body)
1422− {-| (MN _ ap) <- name-}
1575+ | (MN _ ap) <- name
1423− {-, (SLet var val next) <- body-}
1576+ , (SChkCase var cases) <- body
1424− {-, (SChkCase cvar cases) <- next-}
1425− {-, ap == txt "APPLY" =-}
1577+ , ap == txt "APPLY" =
1426− {-let lvar = translateVariableName var-}
1427− {-lookup t = (JSApp-}
1428− {-(JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))-}
1429− {-[JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in-}
1430− {-[ lookupTable "APPLY" [(var, "chk")] var cases-}
1578+ [ lookupTable "APPLY" [] var cases
1431− {-, jsDecl $ JSFunction ["fn0", "arg0"] (-}
1579+ , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1432− {-JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")-}
1433− {-, JSAlloc (translateVariableName var) (-}
1434− {-Just $ translateExpression val-}
1435− {-)-}
1436− {-, JSReturn $ (JSTernary (-}
1580+ JSTernary (
1437− {-(JSVar var `jsInstanceOf` jsCon) `jsAnd`-}
1581+ (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1438− {-(hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))-}
1582+ (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1583+ ) (JSApp
1584+ (JSIndex
1439− {-) (lookup (idrLTNamespace ++ "APPLY")) JSNull)-}
1585+ (JSIdent (idrLTNamespace ++ "APPLY"))
1440− {-]-}
1586+ (JSProj (JSIdent "mfn0") "tag")
1441− {-)-}
1587+ )
1442− {-]-}
1588+ [JSIdent "mfn0", JSIdent "marg0"]
1443−
1589+ ) JSNull
1590+ )
1591+ ]
1592+
1444− {-| (MN _ ev) <- name-}
1593+ | (MN _ ev) <- name
1445− {-, (SChkCase var cases) <- body-}
1594+ , (SChkCase var cases) <- body
1446− {-, ev == txt "EVAL" =-}
1595+ , ev == txt "EVAL" =
1447− {-[ lookupTable "EVAL" [] var cases-}
1596+ [ lookupTable "EVAL" [] var cases
1448− {-, jsDecl $ JSFunction ["arg0"] (JSReturn $-}
1597+ , jsDecl $ JSFunction ["marg0"] (JSReturn $
1449− {-JSTernary (-}
1598+ JSTernary (
1450− {-(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-}
1599+ (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1451− {-(hasProp (idrLTNamespace ++ "EVAL") "arg0")-}
1600+ (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1452− {-) (JSApp-}
1601+ ) (JSApp
1602+ (JSIndex
1453− {-(JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))-}
1603+ (JSIdent (idrLTNamespace ++ "EVAL"))
1604+ (JSProj (JSIdent "marg0") "tag")
1605+ )
1454− {-[JSIdent "arg0"]-}
1606+ [JSIdent "marg0"]
1455− {-) (JSIdent "arg0")-}
1607+ ) (JSIdent "marg0")
1456− {-)-}
1608+ )
1457− {-]-}
1609+ ]
1458 | otherwise =
1610 | otherwise =
1459 let fun = translateExpression body in
1611 let fun = translateExpression body in
1460 [jsDecl $ jsFun fun]
1612 [jsDecl $ jsFun fun]
@@ -1723,6 +1875,12 @@ translateExpression (SError msg) =
1723translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1875translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1724 jsCall (idrRTNamespace ++ "print") [JSVar var]
1876 jsCall (idrRTNamespace ++ "print") [JSVar var]
1725
1877
1878+translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
1879+ JSBinOp "==" (JSVar var) JSNull
1880+
1881+translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1882+ JSBinOp "==" (JSVar lhs) (JSVar rhs)
1883+
1726translateExpression (SForeign _ _ fun args) =
1884translateExpression (SForeign _ _ fun args) =
1727 ffi fun (map generateWrapper args)
1885 ffi fun (map generateWrapper args)
1728 where
1886 where
test/Makefile+1−1
@@ -11,7 +11,7 @@ test_java:
11 perl ./runtest.pl without buffer001 --codegen Java
11 perl ./runtest.pl without buffer001 --codegen Java
12
12
13test_js:
13test_js:
14− @perl ./runtest.pl without reg029 reg031 io001 dsl002 io003 effects001 effects002 basic007 buffer001 --codegen node
14+ @perl ./runtest.pl without reg029 io001 dsl002 io003 effects001 effects002 buffer001 --codegen node
15
15
16test_llvm:
16test_llvm:
17 @perl ./runtest.pl without io003 buffer001 --codegen llvm
17 @perl ./runtest.pl without io003 buffer001 --codegen llvm