git.iko.soy/Idris-dev
on master help sign in
javascript: experimental backend compiles hello world
5d5baa3raichoo
jsrts/Runtime-common.js+22−44
compare with master
unifiedsplit
@@ -1,52 +1,30 @@
1/** @constructor */
1/** @constructor */
2−var __IDRRT__Type = function(type) {
2+var i$VM = function() {
3− this.type = type;
3+ this.valstack = [];
4−};
4+ this.valstack_top = 0;
5+ this.valstack_base = 0;
5
6
6−var __IDRRT__Int = new __IDRRT__Type('Int');
7+ this.ret = null;
7−var __IDRRT__Char = new __IDRRT__Type('Char');
8+ this.reg1 = null;
8−var __IDRRT__String = new __IDRRT__Type('String');
9−var __IDRRT__Integer = new __IDRRT__Type('Integer');
10−var __IDRRT__Float = new __IDRRT__Type('Float');
11−var __IDRRT__Ptr = new __IDRRT__Type('Pointer');
12−var __IDRRT__Forgot = new __IDRRT__Type('Forgot');
13−
14−var __IDRRT__ffiWrap = function(fid) {
15− return function(){
16− var res = fid;
17− var i = 0;
18− var arg;
19− while (res instanceof __IDRRT__Con){
20− arg = arguments[i];
21− res = __IDRRT__tailcall(function(){
22− return __IDR__mAPPLY0(res, arg);
23− });
24− ++i;
25− }
26− return res;
27− }
9+}
28−};
29
10
11+/** @constructor */
30−var __IDRRT__tailcall = function(k) {
12+var i$CON = function(tag,args) {
31− var ret = k();
13+ this.tag = tag;
32− while (ret instanceof __IDRRT__Cont)
14+ this.args = args;
33− ret = ret.k();
15+}
34
16
35− return ret;
17+var i$SLIDE = function(vm,args) {
18+ for (var i = 0; i < args; ++i)
19+ vm.valstack[vm.valstack_base + i] = vm.valstack[vm.valstack_top + i];
36−};
20+}
37
21
38−var __IDRRT__charCode = function(str) {
22+var i$PROJECT = function(vm,val,loc,arity) {
39− var type = typeof str;
23+ for (var i = 0; i < arity; ++i)
40− if (type == "string")
24+ vm.valstack[i + loc] = val.args[i];
41− return str.charCodeAt(0);
42− else
43− return str;
44}
25}
45
26
46−var __IDRRT__fromCharCode = function(chr) {
27+var i$RESERVE = function(vm,n) {
47− var type = typeof chr;
28+ for (var i = 0; i < n; ++i)
48− if (type == "string")
29+ vm.valstack[vm.valstack_top + i] = null;
49− return chr;
50− else
51− return String.fromCharCode(chr);
52}
30}
jsrts/Runtime-node.js+1−1
@@ -1,4 +1,4 @@
1−var __IDRRT__print = (function() {
1+var putStr = (function() {
2 var util = require('util');
2 var util = require('util');
3 return function(s) {
3 return function(s) {
4 util.print(s);
4 util.print(s);
src/IRTS/CodegenJavaScript.hs+292−2278
@@ -93,7 +93,7 @@ data JS = JSRaw String
93 | JSAssign JS JS
93 | JSAssign JS JS
94 | JSAlloc String (Maybe JS)
94 | JSAlloc String (Maybe JS)
95 | JSIndex JS JS
95 | JSIndex JS JS
96− | JSCond [(JS, JS)]
96+ | JSSwitch JS [(JS, JS)] (Maybe JS)
97 | JSTernary JS JS JS
97 | JSTernary JS JS JS
98 | JSParens JS
98 | JSParens JS
99 | JSWhile JS JS
99 | JSWhile JS JS
@@ -105,47 +105,14 @@ data JS = JSRaw String
105
105
106data FFI = FFICode Char | FFIArg Int | FFIError String
106data FFI = FFICode Char | FFIArg Int | FFIError String
107
107
108−
109−ffi :: String -> [String] -> String
110−ffi code args = let parsed = ffiParse code in
111− case ffiError parsed of
112− Just err -> error err
113− Nothing -> renderFFI parsed args
114− where
115− ffiParse :: String -> [FFI]
116− ffiParse "" = []
117− ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
118− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
119− ffiParse ('%':s:ss)
120− | isDigit s =
121− FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
122− | otherwise =
123− [FFIError $ "FFI - Invalid positional argument"]
124− ffiParse (s:ss) = FFICode s : ffiParse ss
125−
126−
127− ffiError :: [FFI] -> Maybe String
128− ffiError [] = Nothing
129− ffiError ((FFIError s):xs) = Just s
130− ffiError (x:xs) = ffiError xs
131−
132−
133− renderFFI :: [FFI] -> [String] -> String
134− renderFFI [] _ = ""
135− renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
136− renderFFI ((FFIArg i) : fs) args
137− | i < length args && i >= 0 = args !! i ++ renderFFI fs args
138− | otherwise = error "FFI - Argument index out of bounds"
139−
140−
141compileJS :: JS -> String
108compileJS :: JS -> String
142compileJS JSNoop = ""
109compileJS JSNoop = ""
143
110
144compileJS (JSAnnotation annotation js) =
111compileJS (JSAnnotation annotation js) =
145 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
112 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
146
113
147−compileJS (JSFFI raw args) =
114+{-compileJS (JSFFI raw args) =-}
148− ffi raw (map compileJS args)
115+ {-ffi raw (map compileJS args)-}
149
116
150compileJS (JSRaw code) =
117compileJS (JSRaw code) =
151 code
118 code
@@ -158,7 +125,7 @@ compileJS (JSFunction args body) =
158 ++ intercalate "," args
125 ++ intercalate "," args
159 ++ "){\n"
126 ++ "){\n"
160 ++ compileJS body
127 ++ compileJS body
161− ++ "\n}"
128+ ++ "\n}\n"
162
129
163compileJS (JSType ty)
130compileJS (JSType ty)
164 | JSIntTy <- ty = idrRTNamespace ++ "Int"
131 | JSIntTy <- ty = idrRTNamespace ++ "Int"
@@ -170,7 +137,7 @@ compileJS (JSType ty)
170 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
137 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
171
138
172compileJS (JSSeq seq) =
139compileJS (JSSeq seq) =
173− intercalate ";\n" (map compileJS seq)
140+ intercalate ";\n" (map compileJS $ filter (/= JSNoop) seq)
174
141
175compileJS (JSReturn val) =
142compileJS (JSReturn val) =
176 "return " ++ compileJS val
143 "return " ++ compileJS val
@@ -203,8 +170,8 @@ compileJS (JSProj obj field)
203 | otherwise =
170 | otherwise =
204 compileJS obj ++ '.' : field
171 compileJS obj ++ '.' : field
205
172
206−compileJS (JSVar var) =
173+{-compileJS (JSVar var) =-}
207− translateVariableName var
174+ {-translateVariableName var-}
208
175
209compileJS JSNull =
176compileJS JSNull =
210 "null"
177 "null"
@@ -232,7 +199,7 @@ compileJS (JSNum num)
232 | JSInteger (JSBigInt i) <- num = show i
199 | JSInteger (JSBigInt i) <- num = show i
233
200
234compileJS (JSAssign lhs rhs) =
201compileJS (JSAssign lhs rhs) =
235− compileJS lhs ++ "=" ++ compileJS rhs
202+ compileJS lhs ++ " = " ++ compileJS rhs
236
203
237compileJS (JSAlloc name val) =
204compileJS (JSAlloc name val) =
238 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
205 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
@@ -240,17 +207,25 @@ compileJS (JSAlloc name val) =
240compileJS (JSIndex lhs rhs) =
207compileJS (JSIndex lhs rhs) =
241 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
208 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
242
209
243−compileJS (JSCond branches) =
210+compileJS (JSSwitch cond branches def) =
244− intercalate " else " $ map createIfBlock branches
211+ "switch(" ++ compileJS cond ++ "){\n"
212+ ++ concatMap mkBranch branches
213+ ++ mkDefault def
214+ ++ "}"
245 where
215 where
246− createIfBlock (JSNoop, e) =
216+ mkBranch :: (JS, JS) -> String
247− "{\n"
217+ mkBranch (tag, code) =
218+ "case " ++ compileJS tag ++ ":\n"
248− ++ compileJS e
219+ ++ compileJS code
249− ++ ";\n}"
220+ ++ "\nbreak;\n"
250− createIfBlock (cond, e) =
221+
251− "if (" ++ compileJS cond ++") {\n"
222+ mkDefault :: Maybe JS -> String
223+ mkDefault Nothing = ""
224+ mkDefault (Just def) =
225+ "default:\n"
252− ++ compileJS e
226+ ++ compileJS def
253− ++ ";\n}"
227+ ++ "\n"
228+
254
229
255compileJS (JSTernary cond true false) =
230compileJS (JSTernary cond true false) =
256 let c = compileJS cond
231 let c = compileJS cond
@@ -272,1229 +247,6 @@ compileJS (JSWord word)
272 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
247 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
273 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
248 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
274
249
275−
276−jsTailcall :: JS -> JS
277−jsTailcall call =
278− jsCall (idrRTNamespace ++ "tailcall") [
279− JSFunction [] (JSReturn call)
280− ]
281−
282−
283−jsCall :: String -> [JS] -> JS
284−jsCall fun = JSApp (JSIdent fun)
285−
286−
287−jsMeth :: JS -> String -> [JS] -> JS
288−jsMeth obj meth =
289− JSApp (JSProj obj meth)
290−
291−
292−jsInstanceOf :: JS -> JS -> JS
293−jsInstanceOf = JSBinOp "instanceof"
294−
295−
296−jsEq :: JS -> JS -> JS
297−jsEq = JSBinOp "=="
298−
299−jsNotEq :: JS -> JS -> JS
300−jsNotEq = JSBinOp "!="
301−
302−jsAnd :: JS -> JS -> JS
303−jsAnd = JSBinOp "&&"
304−
305−
306−jsOr :: JS -> JS -> JS
307−jsOr = JSBinOp "||"
308−
309−
310−jsType :: JS
311−jsType = JSIdent $ idrRTNamespace ++ "Type"
312−
313−
314−jsCon :: JS
315−jsCon = JSIdent $ idrRTNamespace ++ "Con"
316−
317−
318−jsTag :: JS -> JS
319−jsTag obj = JSProj obj "tag"
320−
321−
322−jsTypeTag :: JS -> JS
323−jsTypeTag obj = JSProj obj "type"
324−
325−
326−jsBigInt :: JS -> JS
327−jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
328−jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
329−jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
330−
331−
332−jsVar :: Int -> String
333−jsVar = ("__var_" ++) . show
334−
335−
336−jsLet :: String -> JS -> JS -> JS
337−jsLet name value body =
338− JSApp (
339− JSFunction [name] (
340− JSReturn body
341− )
342− ) [value]
343−
344−
345−jsError :: String -> JS
346−jsError err = JSApp (JSFunction [] (JSError err)) []
347−
348−jsUnPackBits :: JS -> JS
349−jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
350−
351−
352−jsPackUBits8 :: JS -> JS
353−jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
354−
355−jsPackUBits16 :: JS -> JS
356−jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
357−
358−jsPackUBits32 :: JS -> JS
359−jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
360−
361−jsPackSBits8 :: JS -> JS
362−jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
363−
364−jsPackSBits16 :: JS -> JS
365−jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
366−
367−jsPackSBits32 :: JS -> JS
368−jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
369−
370−
371−foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
372−foldJS tr add acc js =
373− fold js
374− where
375− fold js
376− | JSFunction args body <- js =
377− add (tr js) (fold body)
378− | JSSeq seq <- js =
379− add (tr js) $ foldl' add acc (map fold seq)
380− | JSReturn ret <- js =
381− add (tr js) (fold ret)
382− | JSApp lhs rhs <- js =
383− add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
384− | JSNew _ args <- js =
385− add (tr js) $ foldl' add acc $ map fold args
386− | JSBinOp _ lhs rhs <- js =
387− add (tr js) $ add (fold lhs) (fold rhs)
388− | JSPreOp _ val <- js =
389− add (tr js) $ fold val
390− | JSPostOp _ val <- js =
391− add (tr js) $ fold val
392− | JSProj obj _ <- js =
393− add (tr js) (fold obj)
394− | JSArray vals <- js =
395− add (tr js) $ foldl' add acc $ map fold vals
396− | JSAssign lhs rhs <- js =
397− add (tr js) $ add (fold lhs) (fold rhs)
398− | JSIndex lhs rhs <- js =
399− add (tr js) $ add (fold lhs) (fold rhs)
400− | JSAlloc _ val <- js =
401− add (tr js) $ fromMaybe acc $ fmap fold val
402− | JSTernary c t f <- js =
403− add (tr js) $ add (fold c) (add (fold t) (fold f))
404− | JSParens val <- js =
405− add (tr js) $ fold val
406− | JSCond conds <- js =
407− add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
408− | JSWhile cond body <- js =
409− add (tr js) $ add (fold cond) (fold body)
410− | JSFFI raw args <- js =
411− add (tr js) $ foldl' add acc $ map fold args
412− | JSAnnotation a js <- js =
413− add (tr js) $ fold js
414− | otherwise =
415− tr js
416−
417−
418−transformJS :: (JS -> JS) -> JS -> JS
419−transformJS tr js =
420− transformHelper js
421− where
422− transformHelper :: JS -> JS
423− transformHelper js
424− | JSFunction args body <- js = JSFunction args $ tr body
425− | JSSeq seq <- js = JSSeq $ map tr seq
426− | JSReturn ret <- js = JSReturn $ tr ret
427− | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
428− | JSNew con args <- js = JSNew con $ map tr args
429− | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
430− | JSPreOp op val <- js = JSPreOp op (tr val)
431− | JSPostOp op val <- js = JSPostOp op (tr val)
432− | JSProj obj field <- js = JSProj (tr obj) field
433− | JSArray vals <- js = JSArray $ map tr vals
434− | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
435− | JSAlloc var val <- js = JSAlloc var $ fmap tr val
436− | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
437− | JSCond conds <- js = JSCond $ map (tr *** tr) conds
438− | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
439− | JSParens val <- js = JSParens $ tr val
440− | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
441− | JSFFI raw args <- js = JSFFI raw (map tr args)
442− | JSAnnotation a js <- js = JSAnnotation a (tr js)
443− | otherwise = js
444−
445−
446−moveJSDeclToTop :: String -> [JS] -> [JS]
447−moveJSDeclToTop decl js = move ([], js)
448− where
449− move :: ([JS], [JS]) -> [JS]
450− move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
451− | name == decl = js : front ++ back
452−
453− move (front, js@(JSAlloc name _):back)
454− | name == decl = js : front ++ back
455−
456− move (front, js:back) =
457− move (front ++ [js], back)
458−
459−
460−jsSubst :: JS -> JS -> JS -> JS
461−jsSubst var new old
462− | var == old = new
463−
464−jsSubst (JSIdent var) new (JSVar old)
465− | var == translateVariableName old = new
466− | otherwise = JSVar old
467−
468−jsSubst var new old@(JSIdent _)
469− | var == old = new
470− | otherwise = old
471−
472−jsSubst var new (JSArray fields) =
473− JSArray (map (jsSubst var new) fields)
474−
475−jsSubst var new (JSNew con vals) =
476− JSNew con $ map (jsSubst var new) vals
477−
478−jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
479− | var `notElem` args =
480− JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
481− map (jsSubst (JSIdent var) new) vals
482− )
483− | otherwise =
484− JSApp (JSProj (JSFunction args body) "apply") (
485− map (jsSubst (JSIdent var) new) vals
486− )
487−
488−jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
489− | var /= arg =
490− JSApp (JSFunction [arg] (
491− jsSubst (JSIdent var) new body
492− )) $ map (jsSubst (JSIdent var) new) vals
493− | otherwise =
494− JSApp (JSFunction [arg] (
495− body
496− )) $ map (jsSubst (JSIdent var) new) vals
497−
498−jsSubst var new js = transformJS (jsSubst var new) js
499−
500−
501−removeAllocations :: JS -> JS
502−removeAllocations (JSSeq body) =
503− let opt = removeHelper (map removeAllocations body) in
504− case opt of
505− [ret] -> ret
506− _ -> JSSeq opt
507− where
508− removeHelper :: [JS] -> [JS]
509− removeHelper [js] = [js]
510− removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
511− map (jsSubst (JSIdent name) val) (removeHelper js)
512− removeHelper (j:js) = j : removeHelper js
513−
514−removeAllocations js = transformJS removeAllocations js
515−
516−
517−isJSConstant :: JS -> Bool
518−isJSConstant js
519− | JSString _ <- js = True
520− | JSNum _ <- js = True
521− | JSType _ <- js = True
522− | JSNull <- js = True
523− | JSArray vals <- js = all isJSConstant vals
524−
525− | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
526−
527− | otherwise = False
528−
529−isJSConstantConstructor :: [String] -> JS -> Bool
530−isJSConstantConstructor constants js
531− | isJSConstant js =
532− True
533− | JSArray vals <- js =
534− all (isJSConstantConstructor constants) vals
535− | JSNew "__IDRRT__Con" args <- js =
536− all (isJSConstantConstructor constants) args
537− | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
538− , name `elem` constants =
539− True
540− | JSIdent name <- js
541− , name `elem` constants =
542− True
543− | otherwise = False
544−
545−
546−inlineJS :: JS -> JS
547−inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
548− where
549− inlineJSLet :: JS -> JS
550− inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
551− | opt <- inlineJSLet val =
552− inlineJS $ jsSubst (JSIdent arg) opt ret
553−
554− inlineJSLet js = transformJS inlineJSLet js
555−
556−
557− inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
558− | opt <- inlineCaseMatch val =
559− inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
560−
561− inlineCaseMatch js = transformJS inlineCaseMatch js
562−
563−
564− inlineApply js
565− | JSApp (
566− JSProj (JSFunction args (JSReturn body)) "apply"
567− ) [JSThis, JSProj var "vars"] <- js =
568− inlineApply $ inlineApply' var args body 0
569− | JSReturn (JSApp (
570− JSProj (JSFunction args body@(JSCond _)) "apply"
571− ) [JSThis, JSProj var "vars"]) <- js =
572− inlineApply $ inlineApply' var args body 0
573− where
574− inlineApply' _ [] body _ = body
575− inlineApply' var (a:as) body n =
576− inlineApply' var as (
577− jsSubst (JSIdent a) (
578− JSIndex (JSProj var "vars") (JSNum (JSInt n))
579− ) body
580− ) (n + 1)
581−
582− inlineApply js = transformJS inlineApply js
583−
584−
585− inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
586− inlineError error
587−
588− inlineError js = transformJS inlineError js
589−
590−
591− inlineAssign (JSAssign lhs rhs)
592− | JSVar _ <- lhs
593− , JSVar _ <- rhs
594− , lhs == rhs =
595− lhs
596−
597− inlineAssign (JSAssign lhs rhs)
598− | JSIdent _ <- lhs
599− , JSIdent _ <- rhs
600− , lhs == rhs =
601− lhs
602−
603− inlineAssign js = transformJS inlineAssign js
604−
605−
606−removeEval :: [JS] -> [JS]
607−removeEval js =
608− let (ret, isReduced) = checkEval js in
609− if isReduced
610− then removeEvalApp ret
611− else ret
612− where
613− removeEvalApp js = catMaybes (map removeEvalApp' js)
614− where
615− removeEvalApp' :: JS -> Maybe JS
616− removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
617− removeEvalApp' js = Just $ transformJS match js
618− where
619− match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
620− match js = transformJS match js
621−
622− checkEval :: [JS] -> ([JS], Bool)
623− checkEval js = foldr f ([], False) $ map checkEval' js
624− where
625− f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
626− f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
627− f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
628−
629−
630− checkEval' :: JS -> (Maybe JS, Bool)
631− checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
632− JSSeq [ _
633− , JSReturn (JSIdent "t")
634− ]
635− )) []))) = (Nothing, True)
636−
637− checkEval' js = (Just js, False)
638−
639−
640−reduceJS :: [JS] -> [JS]
641−reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
642−
643−
644−funName :: JS -> String
645−funName (JSAlloc fun _) = fun
646−
647−
648−elimDeadLoop :: [JS] -> [JS]
649−elimDeadLoop js
650− | ret <- deadEvalApplyCases js
651− , ret /= js = elimDeadLoop ret
652− | otherwise = js
653−
654−
655−deadEvalApplyCases :: [JS] -> [JS]
656−deadEvalApplyCases js =
657− let tags = sort $ nub $ concatMap (getTags) js in
658− map (removeHelper tags) js
659− where
660− getTags :: JS -> [Int]
661− getTags = foldJS match (++) []
662− where
663− match js
664− | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
665− | otherwise = []
666−
667−
668− removeHelper :: [Int] -> JS -> JS
669− removeHelper tags (JSAlloc fun (Just (
670− JSApp (JSFunction [] (JSSeq seq)) []))
671− ) =
672− (JSAlloc fun (Just (
673− JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
674− )
675−
676− removeHelper _ js = js
677−
678−
679− remover :: [Int] -> [JS] -> [JS]
680− remover tags (
681− j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
682− )
683− | tag `notElem` tags = remover tags js
684−
685− remover tags (j:js) = j : remover tags js
686− remover _ [] = []
687−
688−
689−initConstructors :: [JS] -> [JS]
690−initConstructors js =
691− let tags = nub $ sort $ concat (map getTags js) in
692− rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
693− where
694− rearrangePrelude :: [JS] -> [JS]
695− rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
696−
697−
698− getTags :: JS -> [Int]
699− getTags = foldJS match (++) []
700− where
701− match js
702− | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
703− | otherwise = []
704−
705−
706− replaceConstructors :: [Int] -> [JS] -> [JS]
707− replaceConstructors tags js = map (replaceHelper tags) js
708− where
709− replaceHelper :: [Int] -> JS -> JS
710− replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
711− | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
712−
713− replaceHelper tags js = transformJS (replaceHelper tags) js
714−
715−
716− createConstant :: Int -> JS
717− createConstant tag =
718− JSAlloc (idrCTRNamespace ++ show tag) (Just (
719− JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
720− ))
721−
722−
723−removeIDs :: [JS] -> [JS]
724−removeIDs js =
725− case partition isID js of
726− ([], rest) -> rest
727− (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
728− where isID :: JS -> Bool
729− isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
730− | JSReturn (JSVar _) <- last body = True
731−
732− isID _ = False
733−
734−
735− idFor :: JS -> (String, Int)
736− idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
737− | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
738−
739−
740− removeIDCall :: [(String, Int)] -> JS -> JS
741− removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
742− JSReturn (JSApp (JSIdent fun) args)
743− )])
744− | Just pos <- lookup fun ids
745− , pos < length args = removeIDCall ids (args !! pos)
746−
747− removeIDCall ids (JSNew _ [JSFunction [] (
748− JSReturn (JSApp (JSIdent fun) args)
749− )])
750− | Just pos <- lookup fun ids
751− , pos < length args = removeIDCall ids (args !! pos)
752−
753− removeIDCall ids js@(JSApp id@(JSIdent fun) args)
754− | Just pos <- lookup fun ids
755− , pos < length args = removeIDCall ids (args !! pos)
756−
757− removeIDCall ids js = transformJS (removeIDCall ids) js
758−
759−
760−inlineFunction :: String -> [String] -> JS -> JS -> JS
761−inlineFunction fun args body js = inline' js
762− where
763− inline' :: JS -> JS
764− inline' (JSApp (JSIdent name) vals)
765− | name == fun =
766− let (js, phs) = insertPlaceHolders args body in
767− inline' $ foldr (uncurry jsSubst) js (zip phs vals)
768−
769− inline' js = transformJS inline' js
770−
771− insertPlaceHolders :: [String] -> JS -> (JS, [JS])
772− insertPlaceHolders args body = insertPlaceHolders' args body []
773− where
774− insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
775− insertPlaceHolders' (a:as) body ph
776− | (body', ph') <- insertPlaceHolders' as body ph =
777− let phvar = JSIdent $ "__PH_" ++ show (length ph') in
778− (jsSubst (JSIdent a) phvar body', phvar : ph')
779−
780− insertPlaceHolders' [] body ph = (body, ph)
781−
782−
783−inlineFunctions :: [JS] -> [JS]
784−inlineFunctions js =
785− inlineHelper ([], js)
786− where
787− inlineHelper :: ([JS], [JS]) -> [JS]
788− inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
789− | countAll fun front + countAll fun back == 0 =
790− inlineHelper (front, back)
791− | Just new <- inlineAble (
792− countAll fun front + countAll fun back
793− ) fun args body =
794− let f = map (inlineFunction fun args new) in
795− inlineHelper (f front, f back)
796−
797− inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
798− inlineHelper (front, []) = front
799−
800−
801− inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
802− inlineAble 1 fun args (JSReturn body)
803− | nonRecur fun body =
804− if all (<= 1) (map ($ body) (map countIDOccurences args))
805− then Just body
806− else Nothing
807−
808− inlineAble _ _ _ _ = Nothing
809−
810−
811− nonRecur :: String -> JS -> Bool
812− nonRecur name body = countInvokations name body == 0
813−
814−
815− countAll :: String -> [JS] -> Int
816− countAll name js = sum $ map (countInvokations name) js
817−
818−
819− countIDOccurences :: String -> JS -> Int
820− countIDOccurences name = foldJS match (+) 0
821− where
822− match :: JS -> Int
823− match js
824− | JSIdent ident <- js
825− , name == ident = 1
826− | otherwise = 0
827−
828−
829− countInvokations :: String -> JS -> Int
830− countInvokations name = foldJS match (+) 0
831− where
832− match :: JS -> Int
833− match js
834− | JSApp (JSIdent ident) _ <- js
835− , name == ident = 1
836− | JSNew con _ <- js
837− , name == con = 1
838− | otherwise = 0
839−
840−
841−reduceContinuations :: JS -> JS
842−reduceContinuations = inlineTC . reduceJS
843− where
844− reduceJS :: JS -> JS
845− reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
846− JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
847− )]) = reduceJS js
848−
849− reduceJS js = transformJS reduceJS js
850−
851−
852− inlineTC :: JS -> JS
853− inlineTC js
854− | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
855− JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
856− JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
857− JSReturn (JSNew "__IDRRT__Cont" _)
858− )])
859− )])
860− )] <- js = inlineTC ret
861−
862− inlineTC js = transformJS inlineTC js
863−
864−
865−
866−
867−reduceConstant :: JS -> JS
868−reduceConstant
869− (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
870− JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
871− )])
872− | JSNum num <- val = val
873− | JSBinOp op lhs rhs <- val =
874− JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
875−
876− | JSApp (JSProj lhs op) [rhs] <- val
877− , op `elem` [ "subtract"
878− , "add"
879− , "multiply"
880− , "divide"
881− , "mod"
882− , "equals"
883− , "lesser"
884− , "lesserOrEquals"
885− , "greater"
886− , "greaterOrEquals"
887− ] = val
888−
889−reduceConstant (JSApp ident [(JSParens js)]) =
890− JSApp ident [reduceConstant js]
891−
892−reduceConstant js = transformJS reduceConstant js
893−
894−
895−reduceConstants :: JS -> JS
896−reduceConstants js
897− | ret <- reduceConstant js
898− , ret /= js = reduceConstants ret
899− | otherwise = js
900−
901−
902−elimDuplicateEvals :: JS -> JS
903−elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
904− JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
905− where
906− elimHelper :: [JS] -> [JS]
907− elimHelper (j@(JSAlloc var (Just val)):js) =
908− j : map (jsSubst val (JSIdent var)) (elimHelper js)
909− elimHelper (j:js) =
910− j : elimHelper js
911− elimHelper [] = []
912−
913−elimDuplicateEvals js = js
914−
915−
916−optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
917−optimizeRuntimeCalls fun tc js =
918− optTC tc : map optHelper js
919− where
920− optHelper :: JS -> JS
921− optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
922− JSFunction [] (JSReturn (JSApp (JSIdent n) args))
923− ])
924− | n == fun = JSApp (JSIdent tc) $ map optHelper args
925−
926− optHelper js = transformJS optHelper js
927−
928−
929− optTC :: String -> JS
930− optTC tc@"__IDRRT__EVALTC" =
931− JSAlloc tc (Just $ JSFunction ["arg0"] (
932− JSSeq [ JSAlloc "ret" $ Just (
933− JSTernary (
934− (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
935− (hasProp "__IDRLT__EVAL" "arg0")
936− ) (JSApp
937− (JSIndex
938− (JSIdent "__IDRLT__EVAL")
939− (JSProj (JSIdent "arg0") "tag")
940− )
941− [JSIdent "arg0"]
942− ) (JSIdent "arg0")
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− optTC tc@"__IDRRT__APPLYTC" =
954− JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
955− JSSeq [ JSAlloc "ret" $ Just (
956− JSTernary (
957− (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
958− (hasProp "__IDRLT__APPLY" "fn0")
959− ) (JSApp
960− (JSIndex
961− (JSIdent "__IDRLT__APPLY")
962− (JSProj (JSIdent "fn0") "tag")
963− )
964− [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
965− ) JSNull
966− )
967− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
968− JSAssign (JSIdent "ret") (
969− JSApp (JSProj (JSIdent "ret") "k") []
970− )
971− )
972− , JSReturn $ JSIdent "ret"
973− ]
974− ))
975−
976−
977− hasProp :: String -> String -> JS
978− hasProp table var =
979− JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
980−
981−
982−unfoldLookupTable :: [JS] -> [JS]
983−unfoldLookupTable input =
984− let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
985− (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
986− js = applyunfold in
987− adaptRuntime $ expandCons evals applys js
988− where
989− adaptRuntime :: [JS] -> [JS]
990− adaptRuntime =
991− adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
992−
993−
994− adaptApply :: [JS] -> [JS]
995− adaptApply js = adaptApply' [] js
996− where
997− adaptApply' :: [JS] -> [JS] -> [JS]
998− adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
999− front ++ (new:back)
1000−
1001− adaptApply' front (next:back) =
1002− adaptApply' (front ++ [next]) back
1003−
1004− adaptApply' front [] = front
1005−
1006− new =
1007− JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
1008− JSTernary (
1009− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1010− (JSProj (JSIdent "mfn0") "app")
1011− ) (JSApp
1012− (JSProj (JSIdent "mfn0") "app")
1013− [JSIdent "mfn0", JSIdent "marg0"]
1014− ) JSNull
1015− )
1016− )
1017−
1018−
1019− adaptApplyTC :: [JS] -> [JS]
1020− adaptApplyTC js = adaptApplyTC' [] js
1021− where
1022− adaptApplyTC' :: [JS] -> [JS] -> [JS]
1023− adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
1024− front ++ (new:back)
1025−
1026− adaptApplyTC' front (next:back) =
1027− adaptApplyTC' (front ++ [next]) back
1028−
1029− adaptApplyTC' front [] = front
1030−
1031− new =
1032− JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
1033− JSSeq [ JSAlloc "ret" $ Just (
1034− JSTernary (
1035− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1036− (JSProj (JSIdent "mfn0") "app")
1037− ) (JSApp
1038− (JSProj (JSIdent "mfn0") "app")
1039− [JSIdent "mfn0", JSIdent "marg0"]
1040− ) JSNull
1041− )
1042− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1043− JSAssign (JSIdent "ret") (
1044− JSApp (JSProj (JSIdent "ret") "k") []
1045− )
1046− )
1047− , JSReturn $ JSIdent "ret"
1048− ]
1049− ))
1050−
1051−
1052− adaptEval :: [JS] -> [JS]
1053− adaptEval js = adaptEval' [] js
1054− where
1055− adaptEval' :: [JS] -> [JS] -> [JS]
1056− adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
1057− front ++ (new:back)
1058−
1059− adaptEval' front (next:back) =
1060− adaptEval' (front ++ [next]) back
1061−
1062− adaptEval' front [] = front
1063−
1064− new =
1065− JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1066− JSTernary (
1067− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1068− (JSProj (JSIdent "marg0") "eval")
1069− ) (JSApp
1070− (JSProj (JSIdent "marg0") "eval")
1071− [JSIdent "marg0"]
1072− ) (JSIdent "marg0")
1073− )
1074− )
1075−
1076−
1077− adaptEvalTC :: [JS] -> [JS]
1078− adaptEvalTC js = adaptEvalTC' [] js
1079− where
1080− adaptEvalTC' :: [JS] -> [JS] -> [JS]
1081− adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
1082− front ++ (new:back)
1083−
1084− adaptEvalTC' front (next:back) =
1085− adaptEvalTC' (front ++ [next]) back
1086−
1087− adaptEvalTC' front [] = front
1088−
1089− new =
1090− JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1091− JSSeq [ JSAlloc "ret" $ Just (
1092− JSTernary (
1093− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1094− (JSProj (JSIdent "marg0") "eval")
1095− ) (JSApp
1096− (JSProj (JSIdent "marg0") "eval")
1097− [JSIdent "marg0"]
1098− ) (JSIdent "marg0")
1099− )
1100− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1101− JSAssign (JSIdent "ret") (
1102− JSApp (JSProj (JSIdent "ret") "k") []
1103− )
1104− )
1105− , JSReturn $ JSIdent "ret"
1106− ]
1107− ))
1108−
1109−
1110− adaptCon js =
1111− adaptCon' [] js
1112− where
1113− adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1114− front ++ (new:back)
1115−
1116− adaptCon' front (next:back) =
1117− adaptCon' (front ++ [next]) back
1118−
1119− adaptCon' front [] = front
1120−
1121−
1122− new =
1123− JSAnnotation JSConstructor $
1124− JSAlloc "__IDRRT__Con" (Just $
1125− JSFunction newArgs (
1126− JSSeq (map newVar newArgs)
1127− )
1128− )
1129− where
1130− newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1131− newArgs = ["tag", "eval", "app", "vars"]
1132−
1133−
1134− unfoldLT :: String -> [JS] -> ([Int], [JS])
1135− unfoldLT lt js =
1136− let (table, code) = extractLT lt js
1137− expanded = expandLT lt table in
1138− (map fst expanded, map snd expanded ++ code)
1139−
1140−
1141− expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1142− expandCons evals applys js =
1143− map expandCons' js
1144− where
1145− expandCons' :: JS -> JS
1146− expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1147− | evalid <- getId "__IDRLT__EVAL" tag evals
1148− , applyid <- getId "__IDRLT__APPLY" tag applys =
1149− JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1150− , maybe JSNull JSIdent evalid
1151− , maybe JSNull JSIdent applyid
1152− , JSArray (map expandCons' args)
1153− ]
1154−
1155− expandCons' js = transformJS expandCons' js
1156−
1157−
1158− getId :: String -> Int -> [Int] -> Maybe String
1159− getId lt tag entries
1160− | tag `elem` entries = Just $ ltIdentifier lt tag
1161− | otherwise = Nothing
1162−
1163−
1164− ltIdentifier :: String -> Int -> String
1165− ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1166− ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1167−
1168−
1169− extractLT :: String -> [JS] -> (JS, [JS])
1170− extractLT lt js =
1171− extractLT' ([], js)
1172− where
1173− extractLT' :: ([JS], [JS]) -> (JS, [JS])
1174− extractLT' (front, js@(JSAlloc fun _):back)
1175− | fun == lt = (js, front ++ back)
1176−
1177− extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1178− extractLT' (front, back) = (JSNoop, front ++ back)
1179−
1180−
1181− expandLT :: String -> JS -> [(Int, JS)]
1182− expandLT lt (
1183− JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1184− ) = catMaybes (map expandEntry seq)
1185− where
1186− expandEntry :: JS -> Maybe (Int, JS)
1187− expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1188− Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1189−
1190− expandEntry js = Nothing
1191−
1192− expandLT lt JSNoop = []
1193−
1194−
1195−removeInstanceChecks :: JS -> JS
1196−removeInstanceChecks (JSCond conds) =
1197− removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1198− removeHelper *** removeInstanceChecks
1199− ) conds
1200− where
1201− removeHelper (
1202− JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1203− ) = removeHelper check
1204− removeHelper js = js
1205−
1206−
1207− eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1208− eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1209− eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1210− eliminateDeadBranches [] = []
1211−
1212−
1213− removeNoopConds :: JS -> JS
1214− removeNoopConds (JSCond [(JSNoop, js)]) = js
1215− removeNoopConds js = js
1216−
1217−removeInstanceChecks js = transformJS removeInstanceChecks js
1218−
1219−
1220−reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1221−reduceLoop reduced (cons, program) =
1222− case partition findConstructors program of
1223− ([], js) -> cons ++ js
1224− (candidates, rest) ->
1225− let names = reduced ++ map funName candidates in
1226− reduceLoop names (
1227− cons ++ map reduce candidates, map (reduceCall names) rest
1228− )
1229− where findConstructors :: JS -> Bool
1230− findConstructors js
1231− | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1232− reducable $ last body
1233− | otherwise = False
1234− where reducable :: JS -> Bool
1235− reducable js
1236− | JSReturn ret <- js = reducable ret
1237− | JSNew _ args <- js = and $ map reducable args
1238− | JSArray fields <- js = and $ map reducable fields
1239− | JSNum _ <- js = True
1240− | JSNull <- js = True
1241− | JSIdent _ <- js = True
1242− | otherwise = False
1243−
1244−
1245− reduce :: JS -> JS
1246− reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1247− | JSReturn js <- last body = (JSAlloc fun (Just js))
1248−
1249− reduce js = js
1250−
1251−
1252− reduceCall :: [String] -> JS -> JS
1253− reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1254− JSReturn (JSApp id@(JSIdent ret) _)
1255− )])
1256− | ret `elem` funs = id
1257−
1258− reduceCall funs js@(JSApp id@(JSIdent fun) _)
1259− | fun `elem` funs = id
1260−
1261− reduceCall funs js = transformJS (reduceCall funs) js
1262−
1263−
1264−extractLocalConstructors :: [JS] -> [JS]
1265−extractLocalConstructors js =
1266− concatMap extractLocalConstructors' js
1267− where
1268− globalCons :: [String]
1269− globalCons = concatMap (getGlobalCons) js
1270−
1271−
1272− extractLocalConstructors' :: JS -> [JS]
1273− extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1274− addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1275− where
1276− cons :: [(JS, JS)]
1277− cons = zipWith genName (foldJS match (++) [] body) [1..]
1278− where
1279− genName :: JS -> Int -> (JS, JS)
1280− genName js id =
1281− (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1282−
1283− match :: JS -> [JS]
1284− match js
1285− | JSNew "__IDRRT__Con" args <- js
1286− , all isConstant args = [js]
1287− | otherwise = []
1288−
1289−
1290− addCons :: [(JS, JS)] -> [JS] -> [JS]
1291− addCons [] js = js
1292− addCons (con@(_, name):cons) js
1293− | sum (map (countOccur name) js) > 0 =
1294− addCons cons ((allocCon con) : js)
1295− | otherwise =
1296− addCons cons js
1297−
1298−
1299− countOccur :: JS -> JS -> Int
1300− countOccur ident js = foldJS match (+) 0 js
1301− where
1302− match :: JS -> Int
1303− match js
1304− | js == ident = 1
1305− | otherwise = 0
1306−
1307−
1308− allocCon :: (JS, JS) -> JS
1309− allocCon (js, JSIdent name) =
1310− JSAlloc name (Just js)
1311−
1312−
1313− isConstant :: JS -> Bool
1314− isConstant js
1315− | JSNew "__IDRRT__Con" args <- js
1316− , all isConstant args =
1317− True
1318− | otherwise =
1319− isJSConstantConstructor globalCons js
1320−
1321− extractLocalConstructors' js = [js]
1322−
1323−
1324− getGlobalCons :: JS -> [String]
1325− getGlobalCons js = foldJS match (++) [] js
1326− where
1327− match :: JS -> [String]
1328− match js
1329− | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1330− [name]
1331− | otherwise =
1332− []
1333−
1334−
1335−evalCons :: [JS] -> [JS]
1336−evalCons js =
1337− map (collapseCont . collapseTC . expandProj . evalCons') js
1338− where
1339− cons :: [(String, JS)]
1340− cons = concatMap getGlobalCons js
1341−
1342− evalCons' :: JS -> JS
1343− evalCons' js = transformJS match js
1344− where
1345− match :: JS -> JS
1346− match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1347− | JSIdent name <- arg
1348− , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1349− arg
1350−
1351− match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1352− | JSIdent name <- arg
1353− , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1354− arg
1355−
1356− match js = transformJS match js
1357−
1358−
1359− lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1360− lookupConstructor ctr cons
1361− | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1362− | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1363− | otherwise = Nothing
1364−
1365−
1366− expandProj :: JS -> JS
1367− expandProj js = transformJS match js
1368− where
1369− match :: JS -> JS
1370− match (
1371− JSIndex (
1372− JSProj (JSIdent name) "vars"
1373− ) (
1374− JSNum (JSInt idx)
1375− )
1376− )
1377− | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1378− args !! idx
1379−
1380− match js = transformJS match js
1381−
1382−
1383− collapseTC :: JS -> JS
1384− collapseTC js = transformJS match js
1385− where
1386− match :: JS -> JS
1387− match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1388− JSReturn (JSIdent name)
1389− )])
1390− | Just _ <- lookup name cons = (JSIdent name)
1391−
1392− match js = transformJS match js
1393−
1394−
1395− collapseCont :: JS -> JS
1396− collapseCont js = transformJS match js
1397− where
1398− match :: JS -> JS
1399− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1400− JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1401− )]) = collapseCont ret
1402−
1403−
1404− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1405− JSReturn (JSIdent name)
1406− )]) = JSIdent name
1407−
1408− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1409− JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1410− )])
1411− | all collapsable args = ret
1412− where
1413− collapsable :: JS -> Bool
1414− collapsable (JSIdent _) = True
1415− collapsable js = isJSConstantConstructor (map fst cons) js
1416−
1417−
1418− match js = transformJS match js
1419−
1420−
1421−elimConds :: [JS] -> [JS]
1422−elimConds js =
1423− let (conds, rest) = partition isCond js in
1424− foldl' eraseCond rest conds
1425− where
1426− isCond :: JS -> Bool
1427− isCond (JSAlloc
1428− fun (Just (JSFunction args (JSCond
1429− [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)
1430− , (JSNoop, JSReturn f)
1431− ])))
1432− )
1433− | isJSConstant t && isJSConstant f =
1434− True
1435−
1436− | JSIdent _ <- t
1437− , JSIdent _ <- f =
1438− True
1439−
1440− isCond (JSAlloc
1441− fun (Just (JSFunction args (JSCond
1442− [ (JSBinOp "==" (JSIdent _) c, JSReturn t)
1443− , (JSNoop, JSReturn f)
1444− ])))
1445− )
1446− | isJSConstant t && isJSConstant f && isJSConstant c =
1447− True
1448−
1449− | JSIdent _ <- t
1450− , JSIdent _ <- f
1451− , isJSConstant c =
1452− True
1453−
1454− isCond _ = False
1455−
1456−
1457− eraseCond :: [JS] -> JS -> [JS]
1458− eraseCond js (JSAlloc
1459− fun (Just (JSFunction args (JSCond
1460− [ (c, JSReturn t)
1461− , (_, JSReturn f)
1462− ])
1463− )
1464− )) = map (inlineFunction fun args (JSTernary c t f)) js
1465−
1466−
1467−removeUselessCons :: [JS] -> [JS]
1468−removeUselessCons js =
1469− let (cons, rest) = partition isUseless js in
1470− foldl' eraseCon rest cons
1471− where
1472− isUseless :: JS -> Bool
1473− isUseless (JSAlloc fun (Just JSNull)) = True
1474− isUseless (JSAlloc fun (Just (JSIdent _))) = True
1475− isUseless _ = False
1476−
1477−
1478− eraseCon :: [JS] -> JS -> [JS]
1479− eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js
1480−
1481−
1482−getGlobalCons :: JS -> [(String, JS)]
1483−getGlobalCons js = foldJS match (++) [] js
1484− where
1485− match :: JS -> [(String, JS)]
1486− match js
1487− | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1488− [(name, con)]
1489− | (JSAlloc name (Just con@(JSIdent _))) <- js =
1490− [(name, con)]
1491− | otherwise =
1492− []
1493−
1494−
1495−getIncludes :: [FilePath] -> IO [String]
1496−getIncludes = mapM readFile
1497−
1498codegenJavaScript :: CodeGenerator
250codegenJavaScript :: CodeGenerator
1499codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
251codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1500 (includes ci) (outputFile ci) (outputType ci)
252 (includes ci) (outputFile ci) (outputType ci)
@@ -1511,141 +263,114 @@ codegenJS_all
1511 -> OutputType
263 -> OutputType
1512 -> IO ()
264 -> IO ()
1513codegenJS_all target definitions includes filename outputType = do
265codegenJS_all target definitions includes filename outputType = do
266+ let code = map (compileJS . translateDecl . toBC) definitions
1514 let (header, rt) = case target of
267 let (header, rt) = case target of
1515 Node ->
268 Node ->
1516 ("#!/usr/bin/env node\n", "-node")
269 ("#!/usr/bin/env node\n", "-node")
1517 JavaScript ->
270 JavaScript ->
1518 ("", "-browser")
271 ("", "-browser")
1519− included <- getIncludes includes
1520 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
272 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1521 idrRuntime <- readFile $ path ++ "Runtime-common.js"
273 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1522 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
274 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
1523− jsbn <- readFile $ path ++ "jsbn/jsbn.js"
275+ let runtime = header ++ idrRuntime ++ tgtRuntime
1524− writeFile filename $ header ++ (
276+ writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
1525− intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions
277+ where
1526− )
278+ main :: String
1527−
1528− setPermissions filename (emptyPermissions { readable = True
1529− , executable = target == Node
1530− , writable = True
1531− })
1532− where
1533− def :: [(String, SDecl)]
1534− def = map (first translateNamespace) definitions
1535−
1536−
1537− checkForBigInt :: [JS] -> Bool
1538− checkForBigInt js = occur
1539− where
1540− occur :: Bool
1541− occur = or $ map (foldJS match (||) False) js
1542−
1543− match :: JS -> Bool
1544− match (JSIdent "__IDRRT__bigInt") = True
1545− match (JSWord (JSWord64 _)) = True
1546− match (JSNum (JSInteger _)) = True
1547− match js = False
1548−
1549−
1550− runtime :: String -> String -> String -> [String]
1551− runtime jsbn idrRuntime tgtRuntime =
1552− if checkForBigInt optimized
1553− then [jsbn, idrRuntime, tgtRuntime]
1554− else [idrRuntime, tgtRuntime]
1555−
1556−
1557− optimized :: [JS]
1558− optimized = translate >>> optimize $ def
1559− where
1560− translate p =
1561− prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1562− optimize p =
1563− foldl' (flip ($)) p opt
1564−
1565− opt =
1566− [ removeEval
1567− , map inlineJS
1568− , removeIDs
1569− , reduceJS
1570− , map reduceConstants
1571− , initConstructors
1572− , map removeAllocations
1573− , elimDeadLoop
1574− , map elimDuplicateEvals
1575− , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1576− , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1577− , map removeInstanceChecks
1578− , inlineFunctions
1579− , map reduceContinuations
1580− , extractLocalConstructors
1581− , unfoldLookupTable
1582− , evalCons
1583− , elimConds
1584− , removeUselessCons
1585− ]
1586−
1587− functions :: [String]
1588− functions = map compileJS optimized
279+ main = compileJS $
1589−
1590− prelude :: [JS]
1591− prelude =
1592− [ JSAnnotation JSConstructor $
1593− JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1594− JSAssign (JSProj JSThis "k") (JSIdent "k")
1595− ))
1596− , JSAnnotation JSConstructor $
1597− JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1598− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1599− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1600− ]
1601− ))
1602− ]
1603−
1604− mainLoop :: JS
1605− mainLoop =
1606 JSAlloc "main" $ Just $ JSFunction [] (
280 JSAlloc "main" $ Just $ JSFunction [] (
1607− case target of
281+ JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
1608− Node -> mainFun
282+ , JSApp (JSIdent "mrunMain0") [ JSIdent "vm"
1609− JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)
283+ , JSNum (JSInt 0)
1610− , (exists window, windowMainFun)
284+ ]
1611− , (JSTrue, mainFun)
1612− ]
1613− )
1614− where
1615− exists :: JS -> JS
1616− exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"
1617−
1618− mainFun :: JS
1619− mainFun = jsTailcall $ jsCall runMain []
1620−
1621− window :: JS
1622− window = JSIdent "window"
1623−
1624− document :: JS
1625− document = JSIdent "document"
1626−
1627− windowMainFun :: JS
1628− windowMainFun = jsMeth window "addEventListener" [
1629− JSString "DOMContentLoaded"
1630− , JSFunction [] ( mainFun )
1631− , JSFalse
1632− ]
285+ ]
286+ )
1633
287
1634− isReady :: JS
288+ invokeMain :: String
1635− isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
289+ invokeMain = compileJS $ JSApp (JSIdent "main") []
1636
290
1637− readyState :: JS
1638− readyState = JSProj (JSIdent "document") "readyState"
1639
291
292+translateDecl :: (Name, [BC]) -> JS
293+translateDecl (name, bc) =
294+ JSAlloc (
295+ translateName name
296+ ) (Just $ JSFunction ["vm", "oldbase"] (
297+ JSSeq $ JSAlloc "myoldbase" Nothing : map translateBC bc)
298+ )
1640
299
1641− runMain :: String
300+translateReg :: Reg -> JS
1642− runMain = idrNamespace ++ translateName (sMN 0 "runMain")
301+translateReg reg
302+ | RVal <- reg = JSProj (JSIdent "vm") "ret"
303+ | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
304+ | L 0 <- reg =
305+ JSIndex (
306+ JSProj (JSIdent "vm") "valstack"
307+ ) (JSProj (JSIdent "vm") "valstack_base")
308+ | L n <- reg =
309+ JSIndex (
310+ JSProj (JSIdent "vm") "valstack"
311+ ) (
312+ JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
313+ )
314+ | T 0 <- reg =
315+ JSIndex (
316+ JSProj (JSIdent "vm") "valstack"
317+ ) (JSProj (JSIdent "vm") "valstack_top")
318+ | T n <- reg =
319+ JSIndex (
320+ JSProj (JSIdent "vm") "valstack"
321+ ) (
322+ JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
323+ )
1643
324
325+translateConstant :: Const -> JS
326+translateConstant (I i) = JSNum (JSInt i)
327+translateConstant (Fl f) = JSNum (JSFloat f)
328+translateConstant (Ch c) = JSString $ translateChar c
329+translateConstant (Str s) = JSString $ concatMap translateChar s
330+translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
331+translateConstant StrType = JSType JSStringTy
332+translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
333+translateConstant (AType ATFloat) = JSType JSFloatTy
334+translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
335+translateConstant PtrType = JSType JSPtrTy
336+translateConstant Forgot = JSType JSForgotTy
337+{-translateConstant (BI i) = jsBigInt $ JSString (show i)-}
338+translateConstant (BI i) = JSRaw $ show i
339+translateConstant (B8 b) = JSWord (JSWord8 b)
340+translateConstant (B16 b) = JSWord (JSWord16 b)
341+translateConstant (B32 b) = JSWord (JSWord32 b)
342+translateConstant (B64 b) = JSWord (JSWord64 b)
343+translateConstant c =
344+ jsERROR $ "Unimplemented Constant: " ++ show c
1644
345
1645− invokeLoop :: JS
1646− invokeLoop = jsCall "main" []
1647
346
347+translateChar :: Char -> String
348+translateChar ch
349+ | '\a' <- ch = "\\u0007"
350+ | '\b' <- ch = "\\b"
351+ | '\f' <- ch = "\\f"
352+ | '\n' <- ch = "\\n"
353+ | '\r' <- ch = "\\r"
354+ | '\t' <- ch = "\\t"
355+ | '\v' <- ch = "\\v"
356+ | '\SO' <- ch = "\\u000E"
357+ | '\DEL' <- ch = "\\u007F"
358+ | '\\' <- ch = "\\\\"
359+ | '\"' <- ch = "\\\""
360+ | '\'' <- ch = "\\\'"
361+ | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
362+ | otherwise = [ch]
363+ where
364+ fill :: String -> String
365+ fill s = if length s == 1
366+ then '0' : s
367+ else s
1648
368
369+ asciiTab =
370+ ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
371+ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
372+ '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
373+ '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1649translateIdentifier :: String -> String
374translateIdentifier :: String -> String
1650translateIdentifier =
375translateIdentifier =
1651 replaceReserved . concatMap replaceBadChars
376 replaceReserved . concatMap replaceBadChars
@@ -1706,7 +431,6 @@ translateIdentifier =
1706 , "yield"
431 , "yield"
1707 ]
432 ]
1708
433
1709−
1710translateNamespace :: Name -> String
434translateNamespace :: Name -> String
1711translateNamespace (UN _) = idrNamespace
435translateNamespace (UN _) = idrNamespace
1712translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
436translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
@@ -1714,7 +438,6 @@ translateNamespace (MN _ _) = idrNamespace
1714translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
438translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1715translateNamespace NErased = idrNamespace
439translateNamespace NErased = idrNamespace
1716
440
1717−
1718translateName :: Name -> String
441translateName :: Name -> String
1719translateName (UN name) = 'u' : translateIdentifier (str name)
442translateName (UN name) = 'u' : translateIdentifier (str name)
1720translateName (NS name _) = 'n' : translateName name
443translateName (NS name _) = 'n' : translateName name
@@ -1722,7 +445,6 @@ translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1722translateName (SN name) = 's' : translateSpecialName name
445translateName (SN name) = 's' : translateSpecialName name
1723translateName NErased = "e"
446translateName NErased = "e"
1724
447
1725−
1726translateSpecialName :: SpecialName -> String
448translateSpecialName :: SpecialName -> String
1727translateSpecialName name
449translateSpecialName name
1728 | WhereN i m n <- name =
450 | WhereN i m n <- name =
@@ -1736,906 +458,198 @@ translateSpecialName name
1736 | CaseN n <- name =
458 | CaseN n <- name =
1737 'c' : translateName n
459 'c' : translateName n
1738
460
1739−
461+jsASSIGN :: Reg -> Reg -> JS
1740−translateConstant :: Const -> JS
462+jsASSIGN r1 r2 = JSAssign (translateReg r1) (translateReg r2)
463+
464+jsASSIGNCONST :: Reg -> Const -> JS
1741−translateConstant (I i) = JSNum (JSInt i)
465+jsASSIGNCONST r c = JSAssign (translateReg r) (translateConstant c)
1742−translateConstant (Fl f) = JSNum (JSFloat f)
466+
1743−translateConstant (Ch c) = JSString $ translateChar c
467+jsCALL :: Name -> JS
1744−translateConstant (Str s) = JSString $ concatMap translateChar s
468+jsCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
1745−translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
469+
1746−translateConstant StrType = JSType JSStringTy
470+jsTAILCALL :: Name -> JS
1747−translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
471+jsTAILCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
1748−translateConstant (AType ATFloat) = JSType JSFloatTy
472+
1749−translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
473+jsFOREIGN :: Reg -> String -> [(FType, Reg)] -> JS
1750−translateConstant PtrType = JSType JSPtrTy
474+jsFOREIGN reg n args =
1751−translateConstant Forgot = JSType JSForgotTy
475+ JSAssign (translateReg reg) (JSApp (JSIdent n) (map extract args))
1752−translateConstant (BI i) = jsBigInt $ JSString (show i)
476+ where
1753−translateConstant (B8 b) = JSWord (JSWord8 b)
477+ extract :: (FType, Reg) -> JS
1754−translateConstant (B16 b) = JSWord (JSWord16 b)
478+ extract (ty, reg) =
1755−translateConstant (B32 b) = JSWord (JSWord32 b)
479+ JSIndex (JSProj (translateReg reg) "args") (JSNum (JSInt 0))
1756−translateConstant (B64 b) = JSWord (JSWord64 b)
480+
1757−translateConstant c =
481+jsREBASE :: JS
1758− jsError $ "Unimplemented Constant: " ++ show c
482+jsREBASE =
1759−
483+ JSAssign (
1760−
1761−translateChar :: Char -> String
1762−translateChar ch
1763− | '\a' <- ch = "\\u0007"
1764− | '\b' <- ch = "\\b"
1765− | '\f' <- ch = "\\f"
1766− | '\n' <- ch = "\\n"
1767− | '\r' <- ch = "\\r"
1768− | '\t' <- ch = "\\t"
1769− | '\v' <- ch = "\\v"
1770− | '\SO' <- ch = "\\u000E"
1771− | '\DEL' <- ch = "\\u007F"
1772− | '\\' <- ch = "\\\\"
1773− | '\"' <- ch = "\\\""
1774− | '\'' <- ch = "\\\'"
1775− | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1776− | otherwise = [ch]
1777− where
1778− fill :: String -> String
1779− fill s = if length s == 1
1780− then '0' : s
1781− else s
1782−
1783− asciiTab =
1784− ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1785− '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1786− '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1787− '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1788−
1789−
1790−translateDeclaration :: (String, SDecl) -> [JS]
1791−translateDeclaration (path, SFun name params stackSize body)
1792− | (MN _ ap) <- name
1793− , (SChkCase var cases) <- body
1794− , ap == txt "APPLY" =
1795− [ lookupTable "APPLY" [] var cases
1796− , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1797− JSTernary (
1798− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1799− (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1800− ) (JSApp
1801− (JSIndex
1802− (JSIdent (idrLTNamespace ++ "APPLY"))
1803− (JSProj (JSIdent "mfn0") "tag")
484+ JSProj (JSIdent "vm") "valstack_base"
1804− )
485+ ) (
1805− [JSIdent "mfn0", JSIdent "marg0"]
486+ JSIdent "oldbase"
1806− ) JSNull
487+ )
1807− )
488+
1808− ]
489+jsSTOREOLD :: JS
1809−
490+jsSTOREOLD =
1810− | (MN _ ev) <- name
491+ JSAssign (
1811− , (SChkCase var cases) <- body
492+ JSIdent "myoldbase"
1812− , ev == txt "EVAL" =
493+ ) (
1813− [ lookupTable "EVAL" [] var cases
494+ JSProj (JSIdent "vm") "valstack_base"
1814− , jsDecl $ JSFunction ["marg0"] (JSReturn $
495+ )
1815− JSTernary (
496+
1816− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
497+jsADDTOP :: Int -> JS
1817− (hasProp (idrLTNamespace ++ "EVAL") "marg0")
498+jsADDTOP n
1818− ) (JSApp
499+ | 0 <- n = JSNoop
1819− (JSIndex
1820− (JSIdent (idrLTNamespace ++ "EVAL"))
1821− (JSProj (JSIdent "marg0") "tag")
1822− )
1823− [JSIdent "marg0"]
1824− ) (JSIdent "marg0")
1825− )
1826− ]
1827 | otherwise =
500 | otherwise =
1828− let fun = translateExpression body in
501+ JSBinOp "+=" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
1829− [jsDecl $ jsFun fun]
1830−
1831− where
1832− hasProp :: String -> String -> JS
1833− hasProp table var =
1834− JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1835−
1836−
1837− caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1838− caseFun aux var cse =
1839− let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1840− jsFunAux aux c
1841−
1842−
1843− getTag :: SAlt -> Maybe Int
1844− getTag (SConCase _ tag _ _ _) = Just tag
1845− getTag _ = Nothing
1846−
1847−
1848− lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1849− lookupTable table aux var cases =
1850− JSAlloc (idrLTNamespace ++ table) $ Just (
1851− JSApp (JSFunction [] (
1852− JSSeq $ [
1853− JSAlloc "t" $ Just (JSArray [])
1854− ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1855− JSReturn (JSIdent "t")
1856− ]
1857− )) []
1858− )
1859− where
1860− assignEntries :: [(Int, JS)] -> [JS]
1861− assignEntries entries =
1862− map (\(tag, fun) ->
1863− JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1864− ) entries
1865−
1866−
1867− lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1868− lookupEntry aux var alt = do
1869− tag <- getTag alt
1870− return (tag, caseFun aux var alt)
1871−
1872−
1873− jsDecl :: JS -> JS
1874− jsDecl = JSAlloc (path ++ translateName name) . Just
1875−
1876−
1877− jsFun body = jsFunAux [] body
1878−
1879−
1880− jsFunAux :: [(LVar, String)] -> JS -> JS
1881− jsFunAux aux body =
1882− JSFunction (p ++ map snd aux) (
1883− JSSeq $
1884− zipWith assignVar [0..] p ++
1885− map assignAux aux ++
1886− [JSReturn body]
1887− )
1888− where
1889− assignVar :: Int -> String -> JS
1890− assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1891−
1892−
1893− assignAux :: (LVar, String) -> JS
1894− assignAux (Loc var, val) =
1895− JSAlloc (jsVar var) (Just $ JSIdent val)
1896−
1897−
1898− p :: [String]
1899− p = map translateName params
1900−
1901−
1902−translateVariableName :: LVar -> String
1903−translateVariableName (Loc i) =
1904− jsVar i
1905−
1906−
1907−translateExpression :: SExp -> JS
1908−translateExpression (SLet name value body) =
1909− jsLet (translateVariableName name) (
1910− translateExpression value
1911− ) (translateExpression body)
1912−
1913−translateExpression (SConst cst) =
1914− translateConstant cst
1915−
1916−translateExpression (SV var) =
1917− JSVar var
1918−
1919−translateExpression (SApp tc name vars)
1920− | False <- tc =
1921− jsTailcall $ translateFunctionCall name vars
1922− | True <- tc =
1923− JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1924− JSReturn $ translateFunctionCall name vars
1925− )]
1926− where
1927− translateFunctionCall name vars =
1928− jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1929−
1930−translateExpression (SOp op vars)
1931− | LNoOp <- op = JSVar (last vars)
1932−
1933− | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1934− | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1935− | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1936−
1937− | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1938− | (LPlus (ATInt ITBig)) <- op
1939− , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1940− | (LMinus (ATInt ITBig)) <- op
1941− , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1942− | (LTimes (ATInt ITBig)) <- op
1943− , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1944− | (LSDiv (ATInt ITBig)) <- op
1945− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1946− | (LSRem (ATInt ITBig)) <- op
1947− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1948− | (LEq (ATInt ITBig)) <- op
1949− , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1950− | (LSLt (ATInt ITBig)) <- op
1951− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1952− | (LSLe (ATInt ITBig)) <- op
1953− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1954− | (LSGt (ATInt ITBig)) <- op
1955− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1956− | (LSGe (ATInt ITBig)) <- op
1957− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1958−
1959− | (LPlus ATFloat) <- op
1960− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1961− | (LMinus ATFloat) <- op
1962− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1963− | (LTimes ATFloat) <- op
1964− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1965− | (LSDiv ATFloat) <- op
1966− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1967− | (LEq ATFloat) <- op
1968− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1969− | (LSLt ATFloat) <- op
1970− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1971− | (LSLe ATFloat) <- op
1972− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1973− | (LSGt ATFloat) <- op
1974− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1975− | (LSGe ATFloat) <- op
1976− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1977−
1978− | (LPlus (ATInt ITChar)) <- op
1979− , (lhs:rhs:_) <- vars =
1980− jsCall "__IDRRT__fromCharCode" [
1981− JSBinOp "+" (
1982− jsCall "__IDRRT__charCode" [JSVar lhs]
1983− ) (
1984− jsCall "__IDRRT__charCode" [JSVar rhs]
1985− )
1986− ]
1987−
1988− | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1989− , (arg:_) <- vars =
1990− jsPackUBits8 (
1991− JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))
1992− )
1993−
1994− | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1995− , (arg:_) <- vars =
1996− jsPackUBits16 (
1997− JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))
1998− )
1999−
2000− | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
2001− , (arg:_) <- vars =
2002− jsPackUBits32 (
2003− jsMeth (jsMeth (JSVar arg) "and" [
2004− jsBigInt (JSString $ show 0xFFFFFFFF)
2005− ]) "intValue" []
2006− )
2007−
2008− | (LTrunc ITBig (ITFixed IT64)) <- op
2009− , (arg:_) <- vars =
2010− jsMeth (JSVar arg) "and" [
2011− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2012− ]
2013−
2014− | (LLSHR (ITFixed IT8)) <- op
2015− , (lhs:rhs:_) <- vars =
2016− jsPackUBits8 (
2017− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2018− )
2019−
2020− | (LLSHR (ITFixed IT16)) <- op
2021− , (lhs:rhs:_) <- vars =
2022− jsPackUBits16 (
2023− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2024− )
2025−
2026− | (LLSHR (ITFixed IT32)) <- op
2027− , (lhs:rhs:_) <- vars =
2028− jsPackUBits32 (
2029− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2030− )
2031−
2032− | (LLSHR (ITFixed IT64)) <- op
2033− , (lhs:rhs:_) <- vars =
2034− jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]
2035−
2036− | (LSHL (ITFixed IT8)) <- op
2037− , (lhs:rhs:_) <- vars =
2038− jsPackUBits8 (
2039− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2040− )
2041−
2042− | (LSHL (ITFixed IT16)) <- op
2043− , (lhs:rhs:_) <- vars =
2044− jsPackUBits16 (
2045− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2046− )
2047−
2048− | (LSHL (ITFixed IT32)) <- op
2049− , (lhs:rhs:_) <- vars =
2050− jsPackUBits32 (
2051− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2052− )
2053
502
2054− | (LSHL (ITFixed IT64)) <- op
503+jsTOPBASE :: Int -> JS
2055− , (lhs:rhs:_) <- vars =
504+jsTOPBASE n
2056− jsMeth (jsMeth (JSVar lhs) "shiftLeft" [JSVar rhs]) "and" [
505+ | 0 <- n =
2057− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
506+ JSAssign (
2058− ]
507+ JSProj (JSIdent "vm") "valstack_top"
2059−
2060− | (LAnd (ITFixed IT8)) <- op
2061− , (lhs:rhs:_) <- vars =
2062− jsPackUBits8 (
2063− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2064− )
2065−
2066− | (LAnd (ITFixed IT16)) <- op
2067− , (lhs:rhs:_) <- vars =
2068− jsPackUBits16 (
2069− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2070− )
2071−
2072− | (LAnd (ITFixed IT32)) <- op
2073− , (lhs:rhs:_) <- vars =
2074− jsPackUBits32 (
2075− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2076− )
508+ ) (
2077−
509+ JSProj (JSIdent "vm") "valstack_base"
2078− | (LAnd (ITFixed IT64)) <- op
2079− , (lhs:rhs:_) <- vars =
2080− jsMeth (JSVar lhs) "and" [JSVar rhs]
2081−
2082− | (LOr (ITFixed IT8)) <- op
2083− , (lhs:rhs:_) <- vars =
2084− jsPackUBits8 (
2085− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2086− )
2087−
2088− | (LOr (ITFixed IT16)) <- op
2089− , (lhs:rhs:_) <- vars =
2090− jsPackUBits16 (
2091− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2092− )
2093−
2094− | (LOr (ITFixed IT32)) <- op
2095− , (lhs:rhs:_) <- vars =
2096− jsPackUBits32 (
2097− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2098− )
2099−
2100− | (LOr (ITFixed IT64)) <- op
2101− , (lhs:rhs:_) <- vars =
2102− jsMeth (JSVar lhs) "or" [JSVar rhs]
2103−
2104− | (LXOr (ITFixed IT8)) <- op
2105− , (lhs:rhs:_) <- vars =
2106− jsPackUBits8 (
2107− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2108− )
2109−
2110− | (LXOr (ITFixed IT16)) <- op
2111− , (lhs:rhs:_) <- vars =
2112− jsPackUBits16 (
2113− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2114− )
2115−
2116− | (LXOr (ITFixed IT32)) <- op
2117− , (lhs:rhs:_) <- vars =
2118− jsPackUBits32 (
2119− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2120− )
2121−
2122− | (LXOr (ITFixed IT64)) <- op
2123− , (lhs:rhs:_) <- vars =
2124− jsMeth (JSVar lhs) "xor" [JSVar rhs]
2125−
2126− | (LPlus (ATInt (ITFixed IT8))) <- op
2127− , (lhs:rhs:_) <- vars =
2128− jsPackUBits8 (
2129− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2130− )
2131−
2132− | (LPlus (ATInt (ITFixed IT16))) <- op
2133− , (lhs:rhs:_) <- vars =
2134− jsPackUBits16 (
2135− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2136− )
2137−
2138− | (LPlus (ATInt (ITFixed IT32))) <- op
2139− , (lhs:rhs:_) <- vars =
2140− jsPackUBits32 (
2141− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2142− )
2143−
2144− | (LPlus (ATInt (ITFixed IT64))) <- op
2145− , (lhs:rhs:_) <- vars =
2146− jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [
2147− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2148− ]
2149−
2150− | (LMinus (ATInt (ITFixed IT8))) <- op
2151− , (lhs:rhs:_) <- vars =
2152− jsPackUBits8 (
2153− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2154− )
2155−
2156− | (LMinus (ATInt (ITFixed IT16))) <- op
2157− , (lhs:rhs:_) <- vars =
2158− jsPackUBits16 (
2159− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2160 )
510 )
2161−
511+ | otherwise =
2162− | (LMinus (ATInt (ITFixed IT32))) <- op
512+ JSAssign (
2163− , (lhs:rhs:_) <- vars =
513+ JSProj (JSIdent "vm") "valstack_top"
2164− jsPackUBits32 (
514+ ) (
2165− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
515+ JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
2166− )
2167−
2168− | (LMinus (ATInt (ITFixed IT64))) <- op
2169− , (lhs:rhs:_) <- vars =
2170− jsMeth (jsMeth (JSVar lhs) "subtract" [JSVar rhs]) "and" [
2171− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2172− ]
2173−
2174− | (LTimes (ATInt (ITFixed IT8))) <- op
2175− , (lhs:rhs:_) <- vars =
2176− jsPackUBits8 (
2177− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2178− )
2179−
2180− | (LTimes (ATInt (ITFixed IT16))) <- op
2181− , (lhs:rhs:_) <- vars =
2182− jsPackUBits16 (
2183− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2184− )
2185−
2186− | (LTimes (ATInt (ITFixed IT32))) <- op
2187− , (lhs:rhs:_) <- vars =
2188− jsPackUBits32 (
2189− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2190− )
2191−
2192− | (LTimes (ATInt (ITFixed IT64))) <- op
2193− , (lhs:rhs:_) <- vars =
2194− jsMeth (jsMeth (JSVar lhs) "multiply" [JSVar rhs]) "and" [
2195− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2196− ]
2197−
2198− | (LEq (ATInt (ITFixed IT8))) <- op
2199− , (lhs:rhs:_) <- vars =
2200− jsPackUBits8 (
2201− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2202− )
2203−
2204− | (LEq (ATInt (ITFixed IT16))) <- op
2205− , (lhs:rhs:_) <- vars =
2206− jsPackUBits16 (
2207− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2208− )
2209−
2210− | (LEq (ATInt (ITFixed IT32))) <- op
2211− , (lhs:rhs:_) <- vars =
2212− jsPackUBits32 (
2213− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2214− )
2215−
2216− | (LEq (ATInt (ITFixed IT64))) <- op
2217− , (lhs:rhs:_) <- vars =
2218− jsMeth (jsMeth (JSVar lhs) "equals" [JSVar rhs]) "and" [
2219− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2220− ]
2221−
2222− | (LLt (ITFixed IT8)) <- op
2223− , (lhs:rhs:_) <- vars =
2224− jsPackUBits8 (
2225− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2226− )
2227−
2228− | (LLt (ITFixed IT16)) <- op
2229− , (lhs:rhs:_) <- vars =
2230− jsPackUBits16 (
2231− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2232− )
2233−
2234− | (LLt (ITFixed IT32)) <- op
2235− , (lhs:rhs:_) <- vars =
2236− jsPackUBits32 (
2237− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2238− )
2239−
2240− | (LLt (ITFixed IT64)) <- op
2241− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
2242−
2243− | (LLe (ITFixed IT8)) <- op
2244− , (lhs:rhs:_) <- vars =
2245− jsPackUBits8 (
2246− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2247− )
2248−
2249− | (LLe (ITFixed IT16)) <- op
2250− , (lhs:rhs:_) <- vars =
2251− jsPackUBits16 (
2252− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2253− )
2254−
2255− | (LLe (ITFixed IT32)) <- op
2256− , (lhs:rhs:_) <- vars =
2257− jsPackUBits32 (
2258− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2259− )
2260−
2261− | (LLe (ITFixed IT64)) <- op
2262− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
2263−
2264− | (LGt (ITFixed IT8)) <- op
2265− , (lhs:rhs:_) <- vars =
2266− jsPackUBits8 (
2267− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2268− )
2269−
2270− | (LGt (ITFixed IT16)) <- op
2271− , (lhs:rhs:_) <- vars =
2272− jsPackUBits16 (
2273− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2274− )
2275− | (LGt (ITFixed IT32)) <- op
2276− , (lhs:rhs:_) <- vars =
2277− jsPackUBits32 (
2278− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2279− )
2280−
2281− | (LGt (ITFixed IT64)) <- op
2282− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
2283−
2284− | (LGe (ITFixed IT8)) <- op
2285− , (lhs:rhs:_) <- vars =
2286− jsPackUBits8 (
2287− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2288 )
516 )
2289
517
2290− | (LGe (ITFixed IT16)) <- op
518+jsBASETOP :: Int -> JS
2291− , (lhs:rhs:_) <- vars =
519+jsBASETOP n
2292− jsPackUBits16 (
520+ | 0 <- n =
2293− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
521+ JSAssign (
522+ JSProj (JSIdent "vm") "valstack_base"
523+ ) (
524+ JSProj (JSIdent "vm") "valstack_top"
2294 )
525 )
2295− | (LGe (ITFixed IT32)) <- op
526+ | otherwise =
2296− , (lhs:rhs:_) <- vars =
527+ JSAssign (
2297− jsPackUBits32 (
528+ JSProj (JSIdent "vm") "valstack_base"
2298− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
529+ ) (
530+ JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
2299 )
531 )
2300
532
2301− | (LGe (ITFixed IT64)) <- op
533+jsNULL :: Reg -> JS
2302− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
534+jsNULL r = JSAssign (translateReg r) JSNull
2303−
2304− | (LUDiv (ITFixed IT8)) <- op
2305− , (lhs:rhs:_) <- vars =
2306− jsPackUBits8 (
2307− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2308− )
2309
535
2310− | (LUDiv (ITFixed IT16)) <- op
536+jsERROR :: String -> JS
2311− , (lhs:rhs:_) <- vars =
537+jsERROR = JSError
2312− jsPackUBits16 (
2313− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2314− )
2315
538
2316− | (LUDiv (ITFixed IT32)) <- op
539+jsSLIDE :: Int -> JS
2317− , (lhs:rhs:_) <- vars =
540+jsSLIDE n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
2318− jsPackUBits32 (
2319− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2320− )
2321
541
2322− | (LUDiv (ITFixed IT64)) <- op
542+jsMKCON :: Reg -> Int -> [Reg] -> JS
2323− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
543+jsMKCON r t rs =
544+ JSAssign (translateReg r) (
545+ JSNew "i$CON" [JSNum (JSInt t), JSArray (map translateReg rs)]
546+ )
2324
547
2325− | (LSDiv (ATInt (ITFixed IT8))) <- op
548+jsInstanceOf :: JS -> String -> JS
2326− , (lhs:rhs:_) <- vars =
549+jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
2327− jsPackSBits8 (
2328− JSBinOp "/" (
2329− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2330− ) (
2331− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2332− )
2333− )
2334
550
2335− | (LSDiv (ATInt (ITFixed IT16))) <- op
551+jsOr :: JS -> JS -> JS
2336− , (lhs:rhs:_) <- vars =
2337− jsPackSBits16 (
2338− JSBinOp "/" (
2339− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2340− ) (
2341− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2342− )
2343− )
2344−
2345− | (LSDiv (ATInt (ITFixed IT32))) <- op
2346− , (lhs:rhs:_) <- vars =
2347− jsPackSBits32 (
2348− JSBinOp "/" (
552+jsOr lhs rhs = JSBinOp "||" lhs rhs
2349− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2350− ) (
2351− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2352− )
2353− )
2354−
2355− | (LSDiv (ATInt (ITFixed IT64))) <- op
2356− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
2357−
2358− | (LSRem (ATInt (ITFixed IT8))) <- op
2359− , (lhs:rhs:_) <- vars =
2360− jsPackSBits8 (
2361− JSBinOp "%" (
2362− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2363− ) (
2364− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2365− )
2366− )
2367
553
2368− | (LSRem (ATInt (ITFixed IT16))) <- op
554+jsTypeOf :: JS -> JS
2369− , (lhs:rhs:_) <- vars =
555+jsTypeOf js = JSPreOp "typeof " js
2370− jsPackSBits16 (
2371− JSBinOp "%" (
2372− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2373− ) (
2374− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2375− )
2376− )
2377
556
2378− | (LSRem (ATInt (ITFixed IT32))) <- op
557+jsEq :: JS -> JS -> JS
2379− , (lhs:rhs:_) <- vars =
2380− jsPackSBits32 (
2381− JSBinOp "%" (
558+jsEq = JSBinOp "=="
2382− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2383− ) (
2384− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2385− )
2386− )
2387
559
2388− | (LSRem (ATInt (ITFixed IT64))) <- op
560+jsIsNumber :: JS -> JS
2389− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
561+jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
2390−
562+
2391− | (LCompl (ITFixed IT8)) <- op
563+jsIsNull :: JS -> JS
2392− , (arg:_) <- vars =
564+jsIsNull js = JSBinOp "==" js JSNull
2393− jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
565+
2394−
566+jsTAG :: JS -> JS
2395− | (LCompl (ITFixed IT16)) <- op
567+jsTAG js =
2396− , (arg:_) <- vars =
568+ JSTernary (jsIsNumber js `jsOr` jsIsNull js) (
2397− jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
569+ JSNum (JSInt $ negate 1)
2398−
570+ ) (JSTernary (js `jsInstanceOf` "i$CON") (
2399− | (LCompl (ITFixed IT32)) <- op
571+ JSProj js "tag"
2400− , (arg:_) <- vars =
572+ ) (JSNum (JSInt $ negate 1)))
2401− jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
573+
2402−
574+jsCTAG :: JS -> JS
2403− | (LCompl (ITFixed IT64)) <- op
575+jsCTAG js = JSProj js "tag"
2404− , (arg:_) <- vars =
576+
2405− invokeMeth arg "not" []
577+-- TODO unsafe
2406−
578+jsCASE :: Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
2407− | (LPlus _) <- op
579+jsCASE safe reg cases def =
2408− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
580+ {-JSSwitch (tag safe (translateReg reg)) (-}
2409− | (LMinus _) <- op
581+ JSSwitch (JSTernary (translateReg reg `jsInstanceOf` "i$CON") (
2410− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
2411− | (LTimes _) <- op
2412− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
2413− | (LSDiv _) <- op
2414− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
2415− | (LSRem _) <- op
2416− , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
2417− | (LEq _) <- op
2418− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2419− | (LSLt _) <- op
2420− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2421− | (LSLe _) <- op
2422− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
2423− | (LSGt _) <- op
2424− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
2425− | (LSGe _) <- op
2426− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
2427− | (LAnd _) <- op
2428− , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
2429− | (LOr _) <- op
2430− , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
2431− | (LXOr _) <- op
2432− , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
2433− | (LSHL _) <- op
2434− , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
2435− | (LASHR _) <- op
2436− , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
2437− | (LCompl _) <- op
2438− , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
2439−
2440− | LStrConcat <- op
2441− , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2442− | LStrEq <- op
2443− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2444− | LStrLt <- op
2445− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2446− | LStrLen <- op
2447− , (arg:_) <- vars = JSProj (JSVar arg) "length"
2448−
2449− | (LStrInt ITNative) <- op
2450− , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
2451− | (LIntStr ITNative) <- op
2452− , (arg:_) <- vars = jsCall "String" [JSVar arg]
2453− | (LSExt ITNative ITBig) <- op
2454− , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
2455− | (LTrunc ITBig ITNative) <- op
2456− , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
2457− | (LIntStr ITBig) <- op
2458− , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
2459− | (LStrInt ITBig) <- op
2460− , (arg:_) <- vars = jsBigInt $ JSVar arg
2461− | LFloatStr <- op
2462− , (arg:_) <- vars = jsCall "String" [JSVar arg]
2463− | LStrFloat <- op
2464− , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
2465− | (LIntFloat ITNative) <- op
2466− , (arg:_) <- vars = JSVar arg
2467− | (LFloatInt ITNative) <- op
2468− , (arg:_) <- vars = JSVar arg
2469− | (LChInt ITNative) <- op
2470− , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]
2471− | (LIntCh ITNative) <- op
2472− , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]
2473−
2474− | LFExp <- op
2475− , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
2476− | LFLog <- op
2477− , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
2478− | LFSin <- op
2479− , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
2480− | LFCos <- op
2481− , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
2482− | LFTan <- op
2483− , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
2484− | LFASin <- op
2485− , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
2486− | LFACos <- op
2487− , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
2488− | LFATan <- op
2489− , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
2490− | LFSqrt <- op
2491− , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
2492− | LFFloor <- op
2493− , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
2494− | LFCeil <- op
2495− , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
2496−
2497− | LStrCons <- op
2498− , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2499− | LStrHead <- op
2500− , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
2501− | LStrRev <- op
2502− , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
2503− | LStrIndex <- op
2504− , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
2505− | LStrTail <- op
2506− , (arg:_) <- vars = let v = translateVariableName arg in
2507− JSApp (JSProj (JSIdent v) "substr") [
2508− JSNum (JSInt 1),
2509− JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
582+ JSProj (translateReg reg) "tag") (JSNum (JSInt $ negate 1))) (
583+ map ((JSNum . JSInt) *** prepBranch) cases
584+ ) (fmap prepBranch def)
585+ where
586+ tag :: Bool -> JS -> JS
587+ tag True = jsCTAG
588+ tag False = jsTAG
589+ prepBranch :: [BC] -> JS
590+ prepBranch bc = JSSeq $ map translateBC bc
591+
592+jsCONSTCASE :: Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
593+jsCONSTCASE reg cases def =
594+ JSSwitch (translateReg reg) (
595+ map (translateConstant *** prepBranch) cases
596+ ) (fmap prepBranch def)
597+ where
598+ prepBranch :: [BC] -> JS
599+ prepBranch bc = JSSeq $ map translateBC bc
600+
601+jsPROJECT :: Reg -> Int -> Int -> JS
602+jsPROJECT reg loc ar =
603+ JSApp (JSIdent "i$PROJECT") [ JSIdent "vm"
604+ , translateReg reg
605+ , JSNum (JSInt loc)
606+ , JSNum (JSInt ar)
2510 ]
607 ]
2511− | LSystemInfo <- op
2512− , (arg:_) <- vars = jsCall "__IDRRT__systemInfo" [JSVar arg]
2513− | LNullPtr <- op
2514− , (_) <- vars = JSNull
2515
608
609+jsOP :: Reg -> PrimFn -> [Reg] -> JS
610+jsOP reg op args = JSAssign (translateReg reg) jsOP'
2516 where
611 where
2517− translateBinaryOp :: String -> LVar -> LVar -> JS
612+ jsOP' :: JS
2518− translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)
613+ jsOP'
2519−
614+ | LStrConcat <- op
2520−
615+ , (lhs:rhs:_) <- args = JSBinOp "+" (translateReg lhs) (translateReg rhs)
2521− invokeMeth :: LVar -> String -> [LVar] -> JS
616+ | LPlus _ <- op
2522− invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
617+ , (lhs:rhs:_) <- args = JSBinOp "+" (translateReg lhs) (translateReg rhs)
2523−
618+ | LMinus _ <- op
2524−translateExpression (SError msg) =
619+ , (lhs:rhs:_) <- args = JSBinOp "-" (translateReg lhs) (translateReg rhs)
2525− jsError msg
620+ | LIntStr _ <- op
2526−
621+ , (arg:_) <- args = JSApp (JSIdent "String") [translateReg arg]
2527−translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
622+ | LEq _ <- op
2528− jsCall (idrRTNamespace ++ "print") [JSVar var]
623+ , (lhs:rhs:_) <- args = JSBinOp "==" (translateReg lhs) (translateReg rhs)
2529−
624+ | LSLt _ <- op
2530−translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
625+ , (lhs:rhs:_) <- args = JSBinOp "<" (translateReg lhs) (translateReg rhs)
2531− JSBinOp "==" (JSVar var) JSNull
626+ | otherwise = JSRaw $ show op
2532−
627+
2533−translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
628+jsRESERVE :: Int -> JS
2534− JSBinOp "==" (JSVar lhs) (JSVar rhs)
629+jsRESERVE n = JSNoop -- JSApp (JSIdent "i$RESERVE") [JSIdent "vm", JSNum $ JSInt n]
2535−
630+
2536−translateExpression (SForeign _ _ "idris_time" []) =
631+translateBC :: BC -> JS
2537− JSRaw "(new Date()).getTime()"
632+translateBC bc
2538−
633+ | ASSIGN r1 r2 <- bc = jsASSIGN r1 r2
2539−translateExpression (SForeign _ _ fun args) =
634+ | ASSIGNCONST r c <- bc = jsASSIGNCONST r c
2540− JSFFI fun (map generateWrapper args)
635+ | UPDATE r1 r2 <- bc = jsASSIGN r1 r2
2541− where
636+ | ADDTOP n <- bc = jsADDTOP n
2542− generateWrapper (ffunc, name)
637+ | NULL r <- bc = jsNULL r
2543− | FFunction <- ffunc =
638+ | CALL n <- bc = jsCALL n
2544− JSApp (
639+ | TAILCALL n <- bc = jsTAILCALL n
2545− JSIdent $ idrRTNamespace ++ "ffiWrap"
640+ | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN r n a
2546− ) [JSIdent $ translateVariableName name]
641+ | TOPBASE n <- bc = jsTOPBASE n
2547− | FFunctionIO <- ffunc =
642+ | BASETOP n <- bc = jsBASETOP n
2548− JSApp (
643+ | STOREOLD <- bc = jsSTOREOLD
2549− JSIdent $ idrRTNamespace ++ "ffiWrap"
644+ | SLIDE n <- bc = jsSLIDE n
2550− ) [JSIdent $ translateVariableName name]
645+ | REBASE <- bc = jsREBASE
2551−
646+ | RESERVE n <- bc = jsRESERVE n
2552− generateWrapper (_, name) =
647+ | MKCON r t rs <- bc = jsMKCON r t rs
2553− JSIdent $ translateVariableName name
648+ | CASE s r c d <- bc = jsCASE s r c d
2554−
649+ | CONSTCASE r c d <- bc = jsCONSTCASE r c d
2555−translateExpression patterncase
650+ | PROJECT r l a <- bc = jsPROJECT r l a
2556− | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
651+ | OP r o a <- bc = jsOP r o a
2557− | (SCase var cases) <- patterncase = caseHelper var cases "cse"
652+ | otherwise = JSRaw $ show bc
2558− where
653+ {-| PROJECTINTO _ _ _ <- bc = undefined-}
2559− caseHelper var cases param =
654+ {-| ERROR e <- bc = jsERROR e-}
2560− JSApp (JSFunction [param] (
2561− JSCond $ map (expandCase param . translateCaseCond param) cases
2562− )) [JSVar var]
2563−
2564−
2565− expandCase :: String -> (Cond, JS) -> (JS, JS)
2566− expandCase _ (RawCond cond, branch) = (cond, branch)
2567− expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
2568− expandCase var (CaseCond caseTy, branch)
2569− | ConCase tag <- caseTy =
2570− let checkCon = JSIdent var `jsInstanceOf` jsCon
2571− checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
2572− (checkCon `jsAnd` checkTag, branch)
2573−
2574− | TypeCase ty <- caseTy =
2575− let checkTy = JSIdent var `jsInstanceOf` jsType
2576− checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
2577− (checkTy `jsAnd` checkTag, branch)
2578−
2579−translateExpression (SCon i name vars) =
2580− JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2581− , JSArray $ map JSVar vars
2582− ]
2583−
2584−translateExpression (SUpdate var@(Loc i) e) =
2585− JSAssign (JSVar var) (translateExpression e)
2586−
2587−translateExpression (SProj var i) =
2588− JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2589−
2590−translateExpression SNothing = JSNull
2591−
2592−translateExpression e =
2593− jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2594−
2595−
2596−data CaseType = ConCase Int
2597− | TypeCase JSType
2598− | DefaultCase
2599− deriving Eq
2600−
2601−
2602−data Cond = CaseCond CaseType
2603− | RawCond JS
2604−
2605−
2606−translateCaseCond :: String -> SAlt -> (Cond, JS)
2607−translateCaseCond _ cse@(SDefaultCase _) =
2608− (CaseCond DefaultCase, translateCase Nothing cse)
2609−
2610−translateCaseCond var cse@(SConstCase ty _)
2611− | StrType <- ty = matchHelper JSStringTy
2612− | PtrType <- ty = matchHelper JSPtrTy
2613− | Forgot <- ty = matchHelper JSForgotTy
2614− | (AType ATFloat) <- ty = matchHelper JSFloatTy
2615− | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
2616− | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
2617− | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
2618− where
2619− matchHelper :: JSType -> (Cond, JS)
2620− matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2621−
2622−translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2623− let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2624− (RawCond cond, translateCase Nothing cse)
2625−
2626−translateCaseCond var cse@(SConstCase cst _) =
2627− let cond = JSIdent var `jsEq` translateConstant cst in
2628− (RawCond cond, translateCase Nothing cse)
2629−
2630−translateCaseCond var cse@(SConCase _ tag _ _ _) =
2631− (CaseCond $ ConCase tag, translateCase (Just var) cse)
2632−
2633
655
2634−translateCase :: Maybe String -> SAlt -> JS
2635−translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2636−translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2637−translateCase (Just var) (SConCase a _ _ vars e) =
2638− let params = map jsVar [a .. (a + length vars)] in
2639− JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2640− JSThis, JSProj (JSIdent var) "vars"
2641− ]