git.iko.soy/Idris-dev
on master help sign in
new javascript backend
commitdc44b02ab5eef5f2ac95af6f54050ef90308c6e7 authorRui Barreiro <rui.barreiro@gmail.com> dateThu 20 Apr 2017, 20:04 (9 years ago) parent385f848
8 files changed+670−1876
compare with master
unifiedsplit
idris.cabal+2−3 jsrts/Runtime-browser.js−17 jsrts/Runtime-common.js−117 jsrts/Runtime-node.js−42 src/IRTS/CodegenJavaScript.hs+18−1296 src/IRTS/JavaScript/AST.hs+172−401 src/IRTS/JavaScript/Codegen.hs+367 src/IRTS/JavaScript/LangTransforms.hs+111
idris.cabal+2−3
@@ -47,9 +47,6 @@ Build-type: Custom
4747Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1
4848
4949Data-files: idrisdoc/styles.css
50− jsrts/Runtime-browser.js
51− jsrts/Runtime-common.js
52− jsrts/Runtime-node.js
5350 jsrts/jsbn/jsbn.js
5451 jsrts/jsbn/LICENSE
5552 rts/arduino/idris_main.c
@@ -223,6 +220,8 @@ Library
223220 , IRTS.CodegenJavaScript
224221 , IRTS.Exports
225222 , IRTS.JavaScript.AST
223+ , IRTS.JavaScript.Codegen
224+ , IRTS.JavaScript.LangTransforms
226225 , IRTS.Compiler
227226 , IRTS.Defunctionalise
228227 , IRTS.DumpBC
jsrts/Runtime-browser.jsdeleted−17
@@ -1,17 +0,0 @@
1−var i$getLine = function() {
2− return prompt("Prelude.getLine");
3−}
4−
5−var i$putStr = function(s) {
6− console.log(s);
7−};
8−
9−var i$systemInfo = function(index) {
10− switch(index) {
11− case 0:
12− return "javascript";
13− case 1:
14− return navigator.platform;
15− }
16− return "";
17−}
jsrts/Runtime-common.jsdeleted−117
@@ -1,117 +0,0 @@
1−/** @constructor */
2−var i$VM = function() {
3− this.valstack = {};
4− this.valstack_top = 0;
5− this.valstack_base = 0;
6−
7− this.ret = null;
8−
9− this.callstack = [];
10−}
11−
12−var i$vm;
13−var i$valstack;
14−var i$valstack_top;
15−var i$valstack_base;
16−var i$ret;
17−var i$callstack;
18−
19−var i$Int = {};
20−var i$String = {};
21−var i$Integer = {};
22−var i$Float = {};
23−var i$Char = {};
24−var i$Ptr = {};
25−var i$Forgot = {};
26−
27−/** @constructor */
28−var i$CON = function(tag,args,app,ev) {
29− this.tag = tag;
30− this.args = args;
31− this.app = app;
32− this.ev = ev;
33−}
34−
35−/** @constructor */
36−var i$POINTER = function(addr) {
37− this.addr = addr;
38−}
39−
40−var i$SCHED = function(vm) {
41− i$vm = vm;
42− i$valstack = vm.valstack;
43− i$valstack_top = vm.valstack_top;
44− i$valstack_base = vm.valstack_base;
45− i$ret = vm.ret;
46− i$callstack = vm.callstack;
47−}
48−
49−var i$SLIDE = function(args) {
50− for (var i = 0; i < args; ++i)
51− i$valstack[i$valstack_base + i] = i$valstack[i$valstack_top + i];
52−}
53−
54−var i$PROJECT = function(val,loc,arity) {
55− for (var i = 0; i < arity; ++i)
56− i$valstack[i$valstack_base + i + loc] = val.args[i];
57−}
58−
59−var i$CALL = function(fun,args) {
60− i$callstack.push(args);
61− i$callstack.push(fun);
62−}
63−
64−var i$ffiWrap = function(fid,oldbase,myoldbase) {
65− return function() {
66− var oldstack = i$callstack;
67− i$callstack = [];
68−
69− var res = fid;
70−
71− for(var i = 0; i < (arguments.length ? arguments.length : 1); ++i) {
72− while (res instanceof i$CON) {
73− i$valstack_top += 1;
74− i$valstack[i$valstack_top] = res;
75− i$valstack[i$valstack_top + 1] = arguments[i];
76− i$SLIDE(2);
77− i$valstack_top = i$valstack_base + 2;
78− i$CALL(_idris__123_APPLY0_125_,[oldbase])
79− while (i$callstack.length) {
80− var func = i$callstack.pop();
81− var args = i$callstack.pop();
82− func.apply(this,args);
83− }
84− res = i$ret;
85− }
86− }
87−
88− i$callstack = oldstack;
89−
90− return i$ret;
91− }
92−}
93−
94−var i$charCode = function(str) {
95− if (typeof str == "string")
96− return str.charCodeAt(0);
97− else
98− return str;
99−}
100−
101−var i$fromCharCode = function(chr) {
102− if (typeof chr == "string")
103− return chr;
104− else
105− return String.fromCharCode(chr);
106−}
107−
108−var i$RUN = function () {
109− for (var i = 0; i < 10000 && i$callstack.length; i++) {
110− var func = i$callstack.pop();
111− var args = i$callstack.pop();
112− func.apply(this,args);
113− };
114−
115− if (i$callstack.length)
116− setTimeout(i$RUN, 0);
117−}
jsrts/Runtime-node.jsdeleted−42
@@ -1,42 +0,0 @@
1−var i$putStr = (function() {
2− var fs = require('fs');
3− return function(s) {
4− fs.writeSync(1,s);
5− };
6−})();
7−
8−var i$getLine = (function() {
9− var fs = require( "fs" )
10−
11− return function() {
12− var ret = "";
13− var b = new Buffer(1024);
14− var i = 0;
15− while(true) {
16− fs.readSync(0, b, i, 1 )
17− if (b[i] == 10) {
18− ret = b.toString('utf8', 0, i);
19− break;
20− }
21− i++;
22− if (i == b.length) {
23− nb = new Buffer (b.length*2);
24− b.copy(nb)
25− b = nb;
26− }
27− }
28−
29− return ret;
30− };
31−})();
32−
33−var i$systemInfo = function(index) {
34− var os = require('os')
35− switch(index) {
36− case 0:
37− return "node";
38− case 1:
39− return os.platform();
40− }
41− return "";
42−}
src/IRTS/CodegenJavaScript.hs+18−1296
@@ -11,88 +11,9 @@ module IRTS.CodegenJavaScript (codegenJavaScript
1111 , JSTarget(..)
1212 ) where
1313
14−import Idris.AbsSyntax hiding (TypeCase)
15−import Idris.Core.TT
16−import IRTS.Bytecode
1714import IRTS.CodegenCommon
18−import IRTS.Defunctionalise
19−import IRTS.Exports
20−import IRTS.JavaScript.AST
21−import IRTS.Lang
22−import IRTS.Simplified
23−import IRTS.System
24−import Util.System
25−
26−import Control.Applicative (pure, (<$>), (<*>))
27−import Control.Arrow
28−import Control.Monad (mapM)
29−import Control.Monad.RWS hiding (mapM)
30−import Control.Monad.State
31−import Data.Char
32−import Data.List
33−import qualified Data.Map.Strict as M
34−import Data.Maybe
35−import qualified Data.Text as T
36−import qualified Data.Text.IO as TIO
37−import Data.Traversable hiding (mapM)
38−import Data.Word
39−import Numeric
15+import IRTS.JavaScript.Codegen
4016import System.Directory
41−import System.FilePath
42−import System.IO
43−
44−
45−data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
46− , compileInfoEvalCases :: [Int]
47− , compileInfoNeedsBigInt :: Bool
48− }
49−
50−
51−initCompileInfo :: [(Name, [BC])] -> CompileInfo
52−initCompileInfo bc =
53− CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
54− where
55− lookupBigInt :: [(Name, [BC])] -> Bool
56− lookupBigInt = any (needsBigInt . snd)
57− where
58− needsBigInt :: [BC] -> Bool
59− needsBigInt bc = any testBCForBigInt bc
60− where
61− testBCForBigInt :: BC -> Bool
62− testBCForBigInt (ASSIGNCONST _ c) =
63− testConstForBigInt c
64−
65− testBCForBigInt (CONSTCASE _ c d) =
66− maybe False needsBigInt d
67− || any (needsBigInt . snd) c
68− || any (testConstForBigInt . fst) c
69−
70− testBCForBigInt (CASE _ _ c d) =
71− maybe False needsBigInt d
72− || any (needsBigInt . snd) c
73−
74− testBCForBigInt _ = False
75−
76− testConstForBigInt :: Const -> Bool
77− testConstForBigInt (BI _) = True
78− testConstForBigInt (B64 _) = True
79− testConstForBigInt _ = False
80−
81−
82− collectCases :: String -> [(Name, [BC])] -> [Int]
83− collectCases fun bc = getCases $ findFunction fun bc
84−
85− findFunction :: String -> [(Name, [BC])] -> [BC]
86− findFunction f ((MN 0 fun, bc):_)
87− | fun == txt f = bc
88− findFunction f (_:bc) = findFunction f bc
89−
90− getCases :: [BC] -> [Int]
91− getCases = concatMap analyze
92− where
93− analyze :: BC -> [Int]
94− analyze (CASE _ _ b _) = map fst b
95− analyze _ = []
9617
9718
9819data JSTarget = Node | JavaScript deriving Eq
@@ -100,1222 +21,23 @@ data JSTarget = Node | JavaScript deriving Eq
10021
10122codegenJavaScript :: CodeGenerator
10223codegenJavaScript ci =
103− codegenJS_all JavaScript (simpleDecls ci)
104− (includes ci) [] (outputFile ci) (exportDecls ci) (outputType ci)
24+ codegenJs (CGConf { header = ""
25+ , initialization = const ""
26+ , writeStrTemplate = "console.log(%0)"
27+ }
28+ )
29+ ci
10530
10631codegenNode :: CodeGenerator
10732codegenNode ci =
108− codegenJS_all Node (simpleDecls ci)
109− (includes ci) (compileLibs ci) (outputFile ci) (exportDecls ci) (outputType ci)
110−
111−codegenJS_all
112− :: JSTarget
113− -> [(Name, SDecl)]
114− -> [FilePath]
115− -> [String]
116− -> FilePath
117− -> [ExportIFace]
118− -> OutputType
119− -> IO ()
120−codegenJS_all target definitions includes libs filename exports outputType = do
121− let bytecode = map toBC definitions
122− let info = initCompileInfo bytecode
123− let js = concatMap (translateDecl info) bytecode
124− let full = concatMap processFunction js
125− let exportedNames = map translateName ((getExpNames exports) ++ [sUN "call__IO"])
126− let code = deadCodeElim exportedNames full
127− let ext = takeExtension filename
128− let isHtml = target == JavaScript && ext == ".html"
129− let htmlPrologue = T.pack "<!doctype html><html><head><script>\n"
130− let htmlEpilogue = T.pack "\n</script></head><body></body></html>"
131− let (cons, opt) = optimizeConstructors code
132− let (header, rt) = case target of
133− Node -> ("#!/usr/bin/env node\n", "-node")
134− JavaScript -> ("", "-browser")
135−
136− included <- concat <$> getIncludes includes
137− path <- getIdrisJSRTSDir
138− idrRuntime <- readFile $ path </> "Runtime-common.js"
139− tgtRuntime <- readFile $ path </> concat ["Runtime", rt, ".js"]
140− jsbn <- if compileInfoNeedsBigInt info
141− then readFile $ path </> "jsbn/jsbn.js"
142− else return ""
143− let runtime = ( header
144− ++ includeLibs libs
145− ++ included
146− ++ jsbn
147− ++ idrRuntime
148− ++ tgtRuntime
149− )
150− let jsSource = T.pack runtime
151− `T.append` T.concat (map compileJS opt)
152− `T.append` T.concat (map compileJS cons)
153− `T.append` T.concat (map compileJS (map genInterface (concatMap getExps exports)))
154− `T.append` main
155− `T.append` invokeMain
156− let source = if isHtml
157− then htmlPrologue `T.append` jsSource `T.append` htmlEpilogue
158− else jsSource
159− writeSourceText filename source
160− setPermissions filename (emptyPermissions { readable = True
161− , executable = target == Node
162− , writable = True
163− })
164− where
165− deadCodeElim :: [String] -> [JS] -> [JS]
166− deadCodeElim exports js = concatMap (collectFunctions exports) js
167− where
168− collectFunctions :: [String] -> JS -> [JS]
169− collectFunctions _ fun@(JSAlloc name _)
170− | name == translateName (sMN 0 "runMain") = [fun]
171−
172− collectFunctions exports fun@(JSAlloc name _)
173− | name `elem` exports = [fun]
174−
175− collectFunctions _ fun@(JSAlloc name (Just (JSFunction _ body))) =
176− let invokations = sum $ map (
177− \x -> execState (countInvokations name x) 0
178− ) js
179− in if invokations == 0
180− then []
181− else [fun]
182−
183− countInvokations :: String -> JS -> State Int ()
184− countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
185− countInvokations name body
186−
187− countInvokations name (JSSeq seq) =
188− void $ traverse (countInvokations name) seq
189−
190− countInvokations name (JSAssign _ rhs) =
191− countInvokations name rhs
192−
193− countInvokations name (JSCond conds) =
194− void $ traverse (
195− runKleisli $ arr id *** Kleisli (countInvokations name)
196− ) conds
197−
198− countInvokations name (JSSwitch _ conds def) =
199− void $ traverse (
200− runKleisli $ arr id *** Kleisli (countInvokations name)
201− ) conds >> traverse (countInvokations name) def
202−
203− countInvokations name (JSApp lhs rhs) =
204− void $ countInvokations name lhs >> traverse (countInvokations name) rhs
205−
206− countInvokations name (JSNew _ args) =
207− void $ traverse (countInvokations name) args
208−
209− countInvokations name (JSArray args) =
210− void $ traverse (countInvokations name) args
211−
212− countInvokations name (JSIdent name')
213− | name == name' = get >>= put . (+1)
214− | otherwise = return ()
215−
216− countInvokations _ _ = return ()
217−
218− processFunction :: JS -> [JS]
219− processFunction =
220− collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
221−
222− includeLibs :: [String] -> String
223− includeLibs =
224− concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
225−
226− getIncludes :: [FilePath] -> IO [String]
227− getIncludes = mapM readFile
228−
229− main :: T.Text
230− main =
231− compileJS $ JSAlloc "main" (Just $
232− JSFunction [] (
233− case target of
234− Node -> mainFun
235− JavaScript -> jsMain
236− )
237− )
238−
239− jsMain :: JS
240− jsMain =
241− JSCond [ (exists document `jsAnd` isReady, mainFun)
242− , (exists window, windowMainFun)
243− , (JSTrue, mainFun)
244− ]
245− where
246− exists :: JS -> JS
247− exists js = jsTypeOf js `jsNotEq` JSString "undefined"
248−
249− window :: JS
250− window = JSIdent "window"
251−
252− document :: JS
253− document = JSIdent "document"
254−
255− windowMainFun :: JS
256− windowMainFun =
257− jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
258− , JSFunction [] ( mainFun )
259− , JSFalse
260− ]
261−
262− isReady :: JS
263− isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
264−
265− readyState :: JS
266− readyState = JSProj (JSIdent "document") "readyState"
267−
268− mainFun :: JS
269− mainFun =
270− JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
271− , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
272− , JSApp (
273− JSIdent (translateName (sMN 0 "runMain"))
274− ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
275− , JSApp (JSIdent "i$RUN") []
276− ]
277−
278− invokeMain :: T.Text
279− invokeMain = compileJS $ JSApp (JSIdent "main") []
280− getExps (Export _ _ exp) = exp
281−
282−optimizeConstructors :: [JS] -> ([JS], [JS])
283−optimizeConstructors js =
284− let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
285− (map (allocCon . snd) (M.toList cons), js')
286− where
287− allocCon :: (String, JS) -> JS
288− allocCon (name, con) = JSAlloc name (Just con)
289−
290− newConstructor :: Int -> String
291− newConstructor n = "i$CON$" ++ show n
292−
293− optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
294− optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
295− , JSArray []
296− , a
297− , e
298− ]) = do
299− s <- get
300− case M.lookup tag s of
301− Just (i, c) -> return $ JSIdent i
302− Nothing -> do let n = newConstructor tag
303− put $ M.insert tag (n, js) s
304− return $ JSIdent n
305−
306− optimizeConstructor' (JSSeq seq) =
307− JSSeq <$> traverse optimizeConstructor' seq
308−
309− optimizeConstructor' (JSSwitch reg cond def) = do
310− cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
311− def' <- traverse optimizeConstructor' def
312− return $ JSSwitch reg cond' def'
313−
314− optimizeConstructor' (JSCond cond) =
315− JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
316−
317− optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
318− body' <- optimizeConstructor' body
319− return $ JSAlloc fun (Just (JSFunction args body'))
320−
321− optimizeConstructor' (JSAssign lhs rhs) = do
322− lhs' <- optimizeConstructor' lhs
323− rhs' <- optimizeConstructor' rhs
324− return $ JSAssign lhs' rhs'
325−
326− optimizeConstructor' js = return js
327−
328−collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
329−collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
330− where
331− generateSplitFunction :: (Int,JS) -> JS
332− generateSplitFunction (depth, JSAlloc name fun) =
333− JSAlloc (name ++ "$" ++ show depth) fun
334−
335−splitFunction :: JS -> RWS () [(Int,JS)] Int JS
336−splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
337− body' <- splitSequence body
338− return $ JSAlloc name (Just (JSFunction args body'))
339− where
340− splitCondition :: JS -> RWS () [(Int,JS)] Int JS
341− splitCondition js
342− | JSCond branches <- js =
343− JSCond <$> processBranches branches
344− | JSSwitch cond branches def <- js =
345− JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
346− | otherwise = return js
347− where
348− processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
349− processBranches =
350− traverse (runKleisli (arr id *** Kleisli splitSequence))
351−
352− splitSequence :: JS -> RWS () [(Int, JS)] Int JS
353− splitSequence js@(JSSeq seq) =
354− let (pre,post) = break isBranch seq in
355− case post of
356− [_] -> JSSeq <$> traverse splitCondition seq
357− [call@(JSCond _),rest@(JSApp _ _)] -> do
358− rest' <- splitCondition rest
359− call' <- splitCondition call
360− return $ JSSeq (pre ++ [rest', call'])
361− [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
362− rest' <- splitCondition rest
363− call' <- splitCondition call
364− return $ JSSeq (pre ++ [rest', call'])
365− (call:rest) -> do
366− depth <- get
367− put (depth + 1)
368− new <- splitFunction (newFun rest)
369− tell [(depth, new)]
370− call' <- splitCondition call
371− return $ JSSeq (pre ++ (newCall depth : [call']))
372− _ -> JSSeq <$> traverse splitCondition seq
373−
374− splitSequence js = return js
375−
376− isBranch :: JS -> Bool
377− isBranch (JSApp (JSIdent "i$CALL") _) = True
378− isBranch (JSCond _) = True
379− isBranch (JSSwitch _ _ _) = True
380− isBranch _ = False
381−
382− newCall :: Int -> JS
383− newCall depth =
384− JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
385− , JSArray [jsOLDBASE, jsMYOLDBASE]
386− ]
387−
388− newFun :: [JS] -> JS
389− newFun seq =
390− JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
391−
392−splitFunction js = return js
393−
394−translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
395−translateDecl info (name@(MN 0 fun), bc)
396− | txt "APPLY" == fun =
397− allocCaseFunctions (snd body)
398− ++ [ JSAlloc (
399− translateName name
400− ) (Just $ JSFunction ["oldbase"] (
401− JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
402− JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
403− , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
404− )
405− , ( JSNoop
406− , JSSeq $ map (translateBC info) (defaultCase (snd body))
407− )
408− ]
409− ]
410− )
411− )
412− ]
413−
414− | txt "EVAL" == fun =
415− allocCaseFunctions (snd body)
416− ++ [ JSAlloc (
417− translateName name
418− ) (Just $ JSFunction ["oldbase"] (
419− JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
420− JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
421− , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
422− )
423− , ( JSNoop
424− , JSSeq $ map (translateBC info) (defaultCase (snd body))
425− )
426− ]
427− ]
428− )
429− )
430− ]
431− where
432− body :: ([BC], [BC])
433− body = break isCase bc
434−
435− isCase :: BC -> Bool
436− isCase bc
437− | CASE {} <- bc = True
438− | otherwise = False
439−
440− defaultCase :: [BC] -> [BC]
441− defaultCase ((CASE _ _ _ (Just d)):_) = d
442−
443− caseReg :: [BC] -> Reg
444− caseReg ((CASE _ r _ _):_) = r
445−
446− allocCaseFunctions :: [BC] -> [JS]
447− allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
448− allocCaseFunctions _ = []
449−
450− splitBranches :: [(Int, [BC])] -> [JS]
451− splitBranches = map prepBranch
452−
453− prepBranch :: (Int, [BC]) -> JS
454− prepBranch (tag, code) =
455− JSAlloc (
456− translateName name ++ "$" ++ show tag
457− ) (Just $ JSFunction ["oldbase", "myoldbase"] (
458− JSSeq $ map (translateBC info) code
459− )
460− )
461−
462−translateDecl info (name, bc) =
463− [ JSAlloc (
464− translateName name
465− ) (Just $ JSFunction ["oldbase"] (
466− JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
467− )
468− )
469− ]
470−
471−jsFUNPRELUDE :: [JS]
472−jsFUNPRELUDE = [jsALLOCMYOLDBASE]
473−
474−jsALLOCMYOLDBASE :: JS
475−jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
476−
477−translateReg :: Reg -> JS
478−translateReg reg
479− | RVal <- reg = jsRET
480− | Tmp <- reg = JSRaw "//TMPREG"
481− | L n <- reg = jsLOC n
482− | T n <- reg = jsTOP n
483−
484−translateConstant :: Const -> JS
485−translateConstant (I i) = JSNum (JSInt i)
486−translateConstant (Fl f) = JSNum (JSFloat f)
487−translateConstant (Ch c) = JSString $ translateChar c
488−translateConstant (Str s) = JSString $ concatMap translateChar s
489−translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
490−translateConstant StrType = JSType JSStringTy
491−translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
492−translateConstant (AType ATFloat) = JSType JSFloatTy
493−translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
494−translateConstant Forgot = JSType JSForgotTy
495−translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
496−translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
497−translateConstant (BI i) = jsBigInt (JSString $ show i)
498−translateConstant (B8 b) = JSWord (JSWord8 b)
499−translateConstant (B16 b) = JSWord (JSWord16 b)
500−translateConstant (B32 b) = JSWord (JSWord32 b)
501−translateConstant (B64 b) = JSWord (JSWord64 b)
502−translateConstant c =
503− JSError $ "Unimplemented Constant: " ++ show c
504−
505−
506−translateChar :: Char -> String
507−translateChar ch
508− | '\a' <- ch = "\\u0007"
509− | '\b' <- ch = "\\b"
510− | '\f' <- ch = "\\f"
511− | '\n' <- ch = "\\n"
512− | '\r' <- ch = "\\r"
513− | '\t' <- ch = "\\t"
514− | '\v' <- ch = "\\v"
515− | '\SO' <- ch = "\\u000E"
516− | '\DEL' <- ch = "\\u007F"
517− | '\\' <- ch = "\\\\"
518− | '\"' <- ch = "\\\""
519− | '\'' <- ch = "\\\'"
520− | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
521− | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
522− | otherwise = [ch]
523− where
524− fill :: String -> String
525− fill s = case length s of
526− 1 -> "000" ++ s
527− 2 -> "00" ++ s
528− 3 -> "0" ++ s
529− _ -> s
530−
531− asciiTab =
532− ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
533− '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
534− '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
535− '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
536−
537−translateName :: Name -> String
538−translateName n = "_idris_" ++ concatMap cchar (showCG n)
539− where cchar x | isAlphaNum x = [x]
540− | otherwise = "_" ++ show (fromEnum x) ++ "_"
541−
542−jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
543−jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
544−
545−jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
546−jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
547−
548−jsCALL :: CompileInfo -> Name -> JS
549−jsCALL _ n =
550− JSApp (
551− JSIdent "i$CALL"
552− ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
553−
554−jsTAILCALL :: CompileInfo -> Name -> JS
555−jsTAILCALL _ n =
556− JSApp (
557− JSIdent "i$CALL"
558− ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
559−
560−jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
561−jsFOREIGN _ reg n args
562− | n == "isNull"
563− , [(FPtr, arg)] <- args =
564− JSAssign (
565− translateReg reg
566− ) (
567− JSBinOp "==" (translateReg arg) JSNull
568− )
569−
570− | n == "idris_eqPtr"
571− , [(_, lhs),(_, rhs)] <- args =
572− JSAssign (
573− translateReg reg
574− ) (
575− JSBinOp "==" (translateReg lhs) (translateReg rhs)
576− )
577− | otherwise =
578− JSAssign (
579− translateReg reg
580− ) (
581− JSFFI n (map generateWrapper args)
582− )
583− where
584− generateWrapper :: (FType, Reg) -> JS
585− generateWrapper (ty, reg)
586− | FFunction <- ty =
587− JSApp (JSIdent "i$ffiWrap") [ translateReg reg
588− , JSIdent "oldbase"
589− , JSIdent "myoldbase"
590− ]
591− | FFunctionIO <- ty =
592− JSApp (JSIdent "i$ffiWrap") [ translateReg reg
593− , JSIdent "oldbase"
594− , JSIdent "myoldbase"
595− ]
596−
597− generateWrapper (_, reg) =
598− translateReg reg
599−
600−jsREBASE :: CompileInfo -> JS
601−jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
602−
603−jsSTOREOLD :: CompileInfo ->JS
604−jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
605−
606−jsADDTOP :: CompileInfo -> Int -> JS
607−jsADDTOP info n
608− | 0 <- n = JSNoop
609− | otherwise =
610− JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
611−
612−jsTOPBASE :: CompileInfo -> Int -> JS
613−jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
614−jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
615−
616−
617−jsBASETOP :: CompileInfo -> Int -> JS
618−jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
619−jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
620−
621−jsNULL :: CompileInfo -> Reg -> JS
622−jsNULL _ r = JSClear (translateReg r)
623−
624−jsERROR :: CompileInfo -> String -> JS
625−jsERROR _ = JSError
626−
627−jsSLIDE :: CompileInfo -> Int -> JS
628−jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
629−jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
630−
631−jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
632−jsMKCON info r t rs =
633− JSAssign (translateReg r) (
634− JSNew "i$CON" [ JSNum (JSInt t)
635− , JSArray (map translateReg rs)
636− , if t `elem` compileInfoApplyCases info
637− then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
638− else JSNull
639− , if t `elem` compileInfoEvalCases info
640− then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
641− else JSNull
642− ]
643− )
644−
645−jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
646−jsCASE info safe reg cases def =
647− JSSwitch (tag safe $ translateReg reg) (
648− map ((JSNum . JSInt) *** prepBranch) cases
649− ) (fmap prepBranch def)
650− where
651− tag :: Bool -> JS -> JS
652− tag True = jsCTAG
653− tag False = jsTAG
654−
655− prepBranch :: [BC] -> JS
656− prepBranch bc = JSSeq $ map (translateBC info) bc
657−
658− jsTAG :: JS -> JS
659− jsTAG js =
660− (JSTernary (js `jsInstanceOf` "i$CON") (
661− JSProj js "tag"
662− ) (JSNum (JSInt $ negate 1)))
663−
664− jsCTAG :: JS -> JS
665− jsCTAG js = JSProj js "tag"
666−
667−
668−jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
669−jsCONSTCASE info reg cases def =
670− JSCond $ (
671− map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
672− ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
673− where
674− prepBranch :: [BC] -> JS
675− prepBranch bc = JSSeq $ map (translateBC info) bc
676−
677−jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
678−jsPROJECT _ reg loc 0 = JSNoop
679−jsPROJECT _ reg loc 1 =
680− JSAssign (jsLOC loc) (
681− JSIndex (
682− JSProj (translateReg reg) "args"
683− ) (
684− JSNum (JSInt 0)
685− )
686− )
687−jsPROJECT _ reg loc ar =
688− JSApp (JSIdent "i$PROJECT") [ translateReg reg
689− , JSNum (JSInt loc)
690− , JSNum (JSInt ar)
691− ]
692−
693−jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
694−jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
695− where
696− jsOP' :: JS
697− jsOP'
698− | LNoOp <- op = translateReg (last args)
699−
700− | LWriteStr <- op,
701− (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]
702−
703− | LReadStr <- op = JSApp (JSIdent "i$getLine") []
704−
705− | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
706− | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
707− | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
708−
709− | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
710− | (LPlus (ATInt ITBig)) <- op
711− , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
712− | (LMinus (ATInt ITBig)) <- op
713− , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
714− | (LTimes (ATInt ITBig)) <- op
715− , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
716− | (LSDiv (ATInt ITBig)) <- op
717− , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
718− | (LSRem (ATInt ITBig)) <- op
719− , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
720− | (LEq (ATInt ITBig)) <- op
721− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
722− | (LSLt (ATInt ITBig)) <- op
723− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
724− | (LSLe (ATInt ITBig)) <- op
725− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
726− | (LSGt (ATInt ITBig)) <- op
727− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
728− | (LSGe (ATInt ITBig)) <- op
729− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
730−
731− | (LPlus ATFloat) <- op
732− , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
733− | (LMinus ATFloat) <- op
734− , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
735− | (LTimes ATFloat) <- op
736− , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
737− | (LSDiv ATFloat) <- op
738− , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
739− | (LEq ATFloat) <- op
740− , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
741− | (LSLt ATFloat) <- op
742− , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
743− | (LSLe ATFloat) <- op
744− , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
745− | (LSGt ATFloat) <- op
746− , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
747− | (LSGe ATFloat) <- op
748− , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
749−
750− | (LPlus (ATInt ITChar)) <- op
751− , (lhs:rhs:_) <- args =
752− jsCall "i$fromCharCode" [
753− JSBinOp "+" (
754− jsCall "i$charCode" [translateReg lhs]
755− ) (
756− jsCall "i$charCode" [translateReg rhs]
757− )
758− ]
759−
760− | (LTrunc (ITFixed _from) (ITFixed IT8)) <- op
761− , (arg:_) <- args =
762− jsPackUBits8 (
763− JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
764− )
765−
766− | (LTrunc (ITFixed _from) (ITFixed IT16)) <- op
767− , (arg:_) <- args =
768− jsPackUBits16 (
769− JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
770− )
771−
772− | (LTrunc (ITFixed _from) (ITFixed IT32)) <- op
773− , (arg:_) <- args =
774− jsPackUBits32 (
775− jsMeth (jsMeth (translateReg arg) "and" [
776− jsBigInt (JSString $ show 0xFFFFFFFF)
777− ]) "intValue" []
778− )
779−
780− | (LTrunc ITBig (ITFixed IT64)) <- op
781− , (arg:_) <- args =
782− jsMeth (translateReg arg) "and" [
783− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
784− ]
785−
786− | (LLSHR (ITFixed IT8)) <- op
787− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs
788−
789− | (LLSHR (ITFixed IT16)) <- op
790− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs
791−
792− | (LLSHR (ITFixed IT32)) <- op
793− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs
794−
795− | (LLSHR (ITFixed IT64)) <- op
796− , (lhs:rhs:_) <- args =
797− jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
798−
799− | (LSHL (ITFixed IT8)) <- op
800− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs
801−
802− | (LSHL (ITFixed IT16)) <- op
803− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs
804−
805− | (LSHL (ITFixed IT32)) <- op
806− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs
807−
808− | (LSHL (ITFixed IT64)) <- op
809− , (lhs:rhs:_) <- args =
810− jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
811− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
812− ]
813−
814− | (LAnd (ITFixed IT8)) <- op
815− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs
816−
817− | (LAnd (ITFixed IT16)) <- op
818− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs
819−
820− | (LAnd (ITFixed IT32)) <- op
821− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs
822−
823− | (LAnd (ITFixed IT64)) <- op
824− , (lhs:rhs:_) <- args =
825− jsMeth (translateReg lhs) "and" [translateReg rhs]
826−
827− | (LOr (ITFixed IT8)) <- op
828− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs
829−
830− | (LOr (ITFixed IT16)) <- op
831− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs
832−
833− | (LOr (ITFixed IT32)) <- op
834− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs
835−
836− | (LOr (ITFixed IT64)) <- op
837− , (lhs:rhs:_) <- args =
838− jsMeth (translateReg lhs) "or" [translateReg rhs]
839−
840− | (LXOr (ITFixed IT8)) <- op
841− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs
842−
843− | (LXOr (ITFixed IT16)) <- op
844− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs
845−
846− | (LXOr (ITFixed IT32)) <- op
847− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs
848−
849− | (LXOr (ITFixed IT64)) <- op
850− , (lhs:rhs:_) <- args =
851− jsMeth (translateReg lhs) "xor" [translateReg rhs]
852−
853− | (LPlus (ATInt (ITFixed IT8))) <- op
854− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs
855−
856− | (LPlus (ATInt (ITFixed IT16))) <- op
857− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs
858−
859− | (LPlus (ATInt (ITFixed IT32))) <- op
860− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs
861−
862− | (LPlus (ATInt (ITFixed IT64))) <- op
863− , (lhs:rhs:_) <- args =
864− jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
865− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
866− ]
867−
868− | (LMinus (ATInt (ITFixed IT8))) <- op
869− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs
870−
871− | (LMinus (ATInt (ITFixed IT16))) <- op
872− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs
873−
874− | (LMinus (ATInt (ITFixed IT32))) <- op
875− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs
876−
877− | (LMinus (ATInt (ITFixed IT64))) <- op
878− , (lhs:rhs:_) <- args =
879− jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
880− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
881− ]
882−
883− | (LTimes (ATInt (ITFixed IT8))) <- op
884− , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs
885−
886− | (LTimes (ATInt (ITFixed IT16))) <- op
887− , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs
888−
889− | (LTimes (ATInt (ITFixed IT32))) <- op
890− , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs
891−
892− | (LTimes (ATInt (ITFixed IT64))) <- op
893− , (lhs:rhs:_) <- args =
894− jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
895− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
896− ]
897−
898− | (LEq (ATInt (ITFixed IT8))) <- op
899− , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
900−
901− | (LEq (ATInt (ITFixed IT16))) <- op
902− , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
903−
904− | (LEq (ATInt (ITFixed IT32))) <- op
905− , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
906−
907− | (LEq (ATInt (ITFixed IT64))) <- op
908− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
909−
910− | (LLt (ITFixed IT8)) <- op
911− , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
912−
913− | (LLt (ITFixed IT16)) <- op
914− , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
915−
916− | (LLt (ITFixed IT32)) <- op
917− , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
918−
919− | (LLt (ITFixed IT64)) <- op
920− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
921−
922− | (LLe (ITFixed IT8)) <- op
923− , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
924−
925− | (LLe (ITFixed IT16)) <- op
926− , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
927−
928− | (LLe (ITFixed IT32)) <- op
929− , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
930−
931− | (LLe (ITFixed IT64)) <- op
932− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
933−
934− | (LGt (ITFixed IT8)) <- op
935− , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
936−
937− | (LGt (ITFixed IT16)) <- op
938− , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
939− | (LGt (ITFixed IT32)) <- op
940− , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
941−
942− | (LGt (ITFixed IT64)) <- op
943− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
944−
945− | (LGe (ITFixed IT8)) <- op
946− , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
947−
948− | (LGe (ITFixed IT16)) <- op
949− , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
950− | (LGe (ITFixed IT32)) <- op
951− , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
952−
953− | (LGe (ITFixed IT64)) <- op
954− , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
955−
956− | (LUDiv (ITFixed IT8)) <- op
957− , (lhs:rhs:_) <- args =
958− jsPackUBits8 (
959− JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
960− )
961−
962− | (LUDiv (ITFixed IT16)) <- op
963− , (lhs:rhs:_) <- args =
964− jsPackUBits16 (
965− JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
966− )
967−
968− | (LUDiv (ITFixed IT32)) <- op
969− , (lhs:rhs:_) <- args =
970− jsPackUBits32 (
971− JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
972− )
973−
974− | (LUDiv (ITFixed IT64)) <- op
975− , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
976−
977− | (LSDiv (ATInt (ITFixed IT8))) <- op
978− , (lhs:rhs:_) <- args =
979− jsPackSBits8 (
980− JSBinOp "/" (
981− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
982− ) (
983− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
984− )
985− )
986−
987− | (LSDiv (ATInt (ITFixed IT16))) <- op
988− , (lhs:rhs:_) <- args =
989− jsPackSBits16 (
990− JSBinOp "/" (
991− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
992− ) (
993− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
994− )
995− )
996−
997− | (LSDiv (ATInt (ITFixed IT32))) <- op
998− , (lhs:rhs:_) <- args =
999− jsPackSBits32 (
1000− JSBinOp "/" (
1001− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1002− ) (
1003− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1004− )
1005− )
1006−
1007− | (LSDiv (ATInt (ITFixed IT64))) <- op
1008− , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1009−
1010− | (LSRem (ATInt (ITFixed IT8))) <- op
1011− , (lhs:rhs:_) <- args =
1012− jsPackSBits8 (
1013− JSBinOp "%" (
1014− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1015− ) (
1016− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1017− )
1018− )
1019−
1020− | (LSRem (ATInt (ITFixed IT16))) <- op
1021− , (lhs:rhs:_) <- args =
1022− jsPackSBits16 (
1023− JSBinOp "%" (
1024− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1025− ) (
1026− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1027− )
1028− )
1029−
1030− | (LSRem (ATInt (ITFixed IT32))) <- op
1031− , (lhs:rhs:_) <- args =
1032− jsPackSBits32 (
1033− JSBinOp "%" (
1034− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1035− ) (
1036− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1037− )
1038− )
1039−
1040− | (LSRem (ATInt (ITFixed IT64))) <- op
1041− , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1042−
1043− | (LCompl (ITFixed IT8)) <- op
1044− , (arg:_) <- args =
1045− jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1046−
1047− | (LCompl (ITFixed IT16)) <- op
1048− , (arg:_) <- args =
1049− jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1050−
1051− | (LCompl (ITFixed IT32)) <- op
1052− , (arg:_) <- args =
1053− jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1054−
1055− | (LCompl (ITFixed IT64)) <- op
1056− , (arg:_) <- args = invokeMeth arg "not" []
1057−
1058− | (LPlus _) <- op
1059− , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1060− | (LMinus _) <- op
1061− , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1062− | (LTimes _) <- op
1063− , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1064− | (LSDiv _) <- op
1065− , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1066− | (LSRem _) <- op
1067− , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1068− | (LEq _) <- op
1069− , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1070− | (LSLt _) <- op
1071− , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1072− | (LSLe _) <- op
1073− , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
1074− | (LSGt _) <- op
1075− , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
1076− | (LSGe _) <- op
1077− , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
1078− | (LAnd _) <- op
1079− , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1080− | (LOr _) <- op
1081− , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1082− | (LXOr _) <- op
1083− , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1084− | (LSHL _) <- op
1085− , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1086− | (LASHR _) <- op
1087− , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1088− | (LCompl _) <- op
1089− , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1090−
1091− | LStrConcat <- op
1092− , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1093− | LStrEq <- op
1094− , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1095− | LStrLt <- op
1096− , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1097− | LStrLen <- op
1098− , (arg:_) <- args = JSProj (translateReg arg) "length"
1099− | (LStrInt ITNative) <- op
1100− , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1101− | (LIntStr ITNative) <- op
1102− , (arg:_) <- args = jsCall "String" [translateReg arg]
1103− | (LSExt ITNative ITBig) <- op
1104− , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1105− | (LTrunc ITBig ITNative) <- op
1106− , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1107− | (LIntStr ITBig) <- op
1108− , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1109− | (LStrInt ITBig) <- op
1110− , (arg:_) <- args = jsBigInt $ translateReg arg
1111− | LFloatStr <- op
1112− , (arg:_) <- args = jsCall "String" [translateReg arg]
1113− | LStrFloat <- op
1114− , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1115− | (LIntFloat ITNative) <- op
1116− , (arg:_) <- args = translateReg arg
1117− | (LIntFloat ITBig) <- op
1118− , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1119− | (LFloatInt ITNative) <- op
1120− , (arg:_) <- args = translateReg arg
1121− | (LChInt ITNative) <- op
1122− , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1123− | (LIntCh ITNative) <- op
1124− , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1125−
1126− | LFExp <- op
1127− , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1128− | LFLog <- op
1129− , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1130− | LFSin <- op
1131− , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1132− | LFCos <- op
1133− , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1134− | LFTan <- op
1135− , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1136− | LFASin <- op
1137− , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1138− | LFACos <- op
1139− , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1140− | LFATan <- op
1141− , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1142− | LFSqrt <- op
1143− , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1144− | LFFloor <- op
1145− , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1146− | LFCeil <- op
1147− , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1148− | LFNegate <- op
1149− , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1150−
1151− | LStrCons <- op
1152− , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1153− | LStrHead <- op
1154− , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1155− | LStrRev <- op
1156− , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1157− | LStrIndex <- op
1158− , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1159− | LStrTail <- op
1160− , (arg:_) <- args =
1161− let v = translateReg arg in
1162− JSApp (JSProj v "substr") [
1163− JSNum (JSInt 1),
1164− JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1165− ]
1166− | LStrSubstr <- op
1167− , (offset:length:string:_) <- args =
1168− let off = translateReg offset
1169− len = translateReg length
1170− str = translateReg string
1171− in JSApp (JSProj str "substr") [
1172− jsCall "Math.max" [JSNum (JSInt 0), off],
1173− jsCall "Math.max" [JSNum (JSInt 0), len]
1174− ]
1175−
1176− | LSystemInfo <- op
1177− , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1178− | LExternal nul <- op
1179− , nul == sUN "prim__null"
1180− , _ <- args = JSNull
1181− | LExternal ex <- op
1182− , ex == sUN "prim__eqPtr"
1183− , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs
1184− | otherwise = JSError $ "Not implemented: " ++ show op
1185− where
1186− translateBinaryOp :: String -> Reg -> Reg -> JS
1187− translateBinaryOp op lhs rhs =
1188− JSBinOp op (translateReg lhs) (translateReg rhs)
1189−
1190− translateCompareOp :: String -> Reg -> Reg -> JS
1191− translateCompareOp op lhs rhs =
1192− JSPreOp "+" $ translateBinaryOp op lhs rhs
1193−
1194− bitsBinaryOp :: String -> Reg -> Reg -> JS
1195− bitsBinaryOp op lhs rhs =
1196− JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1197−
1198− bitsCompareOp :: String -> Reg -> Reg -> JS
1199− bitsCompareOp op lhs rhs =
1200− JSPreOp "+" $ bitsBinaryOp op lhs rhs
1201−
1202− invokeMeth :: Reg -> String -> [Reg] -> JS
1203− invokeMeth obj meth args =
1204− JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1205−
1206−
1207−jsRESERVE :: CompileInfo -> Int -> JS
1208−jsRESERVE _ _ = JSNoop
1209−
1210−jsSTACK :: JS
1211−jsSTACK = JSIdent "i$valstack"
1212−
1213−jsCALLSTACK :: JS
1214−jsCALLSTACK = JSIdent "i$callstack"
1215−
1216−jsSTACKBASE :: JS
1217−jsSTACKBASE = JSIdent "i$valstack_base"
1218−
1219−jsSTACKTOP :: JS
1220−jsSTACKTOP = JSIdent "i$valstack_top"
1221−
1222−jsOLDBASE :: JS
1223−jsOLDBASE = JSIdent "oldbase"
1224−
1225−jsMYOLDBASE :: JS
1226−jsMYOLDBASE = JSIdent "myoldbase"
1227−
1228−jsRET :: JS
1229−jsRET = JSIdent "i$ret"
1230−
1231−jsLOC :: Int -> JS
1232−jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1233−jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1234−
1235−jsTOP :: Int -> JS
1236−jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1237−jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1238−
1239−jsPUSH :: [JS] -> JS
1240−jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1241−
1242−jsPOP :: JS
1243−jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1244−
1245−genInterface :: Export -> JS
1246−genInterface (ExportData name) = JSNoop
1247−genInterface (ExportFun name (FStr jsName) ret args) = JSAlloc jsName
1248− (Just (JSFunction [] (JSSeq $
1249− jsFUNPRELUDE ++
1250− pushArgs nargs ++
1251− [jsSTOREOLD d,
1252− jsBASETOP d 0,
1253− jsADDTOP d nargs,
1254− jsCALL d name] ++
1255− retval ret)))
1256− where
1257− nargs = length args
1258− d = CompileInfo [] [] False
1259− pushArg n = JSAssign (jsTOP n) (JSIndex (JSIdent "arguments") (JSNum (JSInt n)))
1260− pushArgs 0 = []
1261− pushArgs n = (pushArg (n-1)):pushArgs (n-1)
1262− retval (FIO t) = [JSApp (JSIdent "i$RUN") [],
1263− JSAssign (jsTOP 0) JSNull,
1264− JSAssign (jsTOP 1) JSNull,
1265− JSAssign (jsTOP 2) (translateReg RVal),
1266− jsSTOREOLD d,
1267− jsBASETOP d 0,
1268− jsADDTOP d 3,
1269− jsCALL d (sUN "call__IO")] ++ retval t
1270− retval t = [JSApp (JSIdent "i$RUN") [], JSReturn (translateReg RVal)]
1271−
1272−translateBC :: CompileInfo -> BC -> JS
1273−translateBC info bc
1274− | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1275− | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1276− | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1277− | ADDTOP n <- bc = jsADDTOP info n
1278− | NULL r <- bc = jsNULL info r
1279− | CALL n <- bc = jsCALL info n
1280− | TAILCALL n <- bc = jsTAILCALL info n
1281− | FOREIGNCALL r _ (FStr n) args
1282− <- bc = jsFOREIGN info r n (map fcall args)
1283− | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1284− | TOPBASE n <- bc = jsTOPBASE info n
1285− | BASETOP n <- bc = jsBASETOP info n
1286− | STOREOLD <- bc = jsSTOREOLD info
1287− | SLIDE n <- bc = jsSLIDE info n
1288− | REBASE <- bc = jsREBASE info
1289− | RESERVE n <- bc = jsRESERVE info n
1290− | MKCON r _ t rs <- bc = jsMKCON info r t rs
1291− | CASE s r c d <- bc = jsCASE info s r c d
1292− | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1293− | PROJECT r l a <- bc = jsPROJECT info r l a
1294− | OP r o a <- bc = jsOP info r o a
1295− | ERROR e <- bc = jsERROR info e
1296− | otherwise = JSRaw $ "//" ++ show bc
1297− where fcall (t, arg) = (toFType t, arg)
1298−
1299−toAType (FCon i)
1300− | i == sUN "JS_IntChar" = ATInt ITChar
1301− | i == sUN "JS_IntNative" = ATInt ITNative
1302−toAType t = error (show t ++ " not defined in toAType")
1303−
1304−toFnType (FApp c [_,_,s,t])
1305− | c == sUN "JS_Fn" = toFnType t
1306−toFnType (FApp c [_,_,r])
1307− | c == sUN "JS_FnIO" = FFunctionIO
1308−toFnType (FApp c [_,r])
1309− | c == sUN "JS_FnBase" = FFunction
1310−toFnType t = error (show t ++ " not defined in toFnType")
1311−
1312−toFType (FCon c)
1313− | c == sUN "JS_Str" = FString
1314− | c == sUN "JS_Float" = FArith ATFloat
1315− | c == sUN "JS_Ptr" = FPtr
1316− | c == sUN "JS_Unit" = FUnit
1317−toFType (FApp c [_,ity])
1318− | c == sUN "JS_IntT" = FArith (toAType ity)
1319−toFType (FApp c [_,fty])
1320− | c == sUN "JS_FnT" = toFnType fty
1321−toFType t = error (show t ++ " not yet defined in toFType")
33+ do
34+ codegenJs (CGConf { header = "#!/usr/bin/env node\n"
35+ , initialization = \x -> if usedWriteStr x then "var fs = require('fs');\n" else ""
36+ , writeStrTemplate = "fs.writeSync(1,%0)"
37+ }
38+ )
39+ ci
40+ setPermissions (outputFile ci) (emptyPermissions { readable = True
41+ , executable = True
42+ , writable = True
43+ })
src/IRTS/JavaScript/AST.hs+172−401
@@ -1,409 +1,180 @@
11{-|
22Module : IRTS.JavaScript.AST
3−Description : Data structures and functions used with the JavaScript codegen.
3+Description : AST for javascrit
44Copyright :
55License : BSD3
66Maintainer : The Idris Community.
77-}
8−{-# LANGUAGE OverloadedStrings, PatternGuards #-}
9−module IRTS.JavaScript.AST where
8+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
109
11−import Data.Char (isDigit)
12−import qualified Data.Text as T
13−import Data.Word
14−
15−data JSType = JSIntTy
16− | JSStringTy
17− | JSIntegerTy
18− | JSFloatTy
19− | JSCharTy
20− | JSPtrTy
21− | JSForgotTy
22− deriving Eq
23−
24−
25−data JSInteger = JSBigZero
26− | JSBigOne
27− | JSBigInt Integer
28− | JSBigIntExpr JS
29− deriving Eq
30−
31−
32−data JSNum = JSInt Int
33− | JSFloat Double
34− | JSInteger JSInteger
35− deriving Eq
36−
37−
38−data JSWord = JSWord8 Word8
39− | JSWord16 Word16
40− | JSWord32 Word32
41− | JSWord64 Word64
42− deriving Eq
43−
44−
45−data JSAnnotation = JSConstructor deriving Eq
46−
47−
48−instance Show JSAnnotation where
49− show JSConstructor = "constructor"
50−
51−
52−data JS = JSRaw String
53− | JSIdent String
54− | JSFunction [String] JS
55− | JSType JSType
56− | JSSeq [JS]
57− | JSReturn JS
58− | JSApp JS [JS]
59− | JSNew String [JS]
60− | JSError String
61− | JSBinOp String JS JS
62− | JSPreOp String JS
63− | JSPostOp String JS
64− | JSProj JS String
65− | JSNull
66− | JSUndefined
67− | JSThis
68− | JSTrue
69− | JSFalse
70− | JSArray [JS]
71− | JSString String
72− | JSNum JSNum
73− | JSWord JSWord
74− | JSAssign JS JS
75− | JSAlloc String (Maybe JS)
76− | JSIndex JS JS
77− | JSSwitch JS [(JS, JS)] (Maybe JS)
78− | JSCond [(JS, JS)]
79− | JSTernary JS JS JS
80− | JSParens JS
81− | JSWhile JS JS
82− | JSFFI String [JS]
83− | JSAnnotation JSAnnotation JS
84− | JSDelete JS
85− | JSClear JS
86− | JSNoop
87− deriving Eq
88−
89−
90−data FFI = FFICode Char | FFIArg Int | FFIError String
91−
92−ffi :: String -> [String] -> T.Text
93−ffi code args = let parsed = ffiParse code in
94− case ffiError parsed of
95− Just err -> error err
96− Nothing -> renderFFI parsed args
97− where
98− ffiParse :: String -> [FFI]
99− ffiParse "" = []
100− ffiParse ['%'] = [FFIError "FFI - Invalid positional argument"]
101− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
102− ffiParse ('%':s:ss)
103− | isDigit s =
104− FFIArg (
105− read $ s : takeWhile isDigit ss
106− ) : ffiParse (dropWhile isDigit ss)
107− | otherwise =
108− [FFIError "FFI - Invalid positional argument"]
109− ffiParse (s:ss) = FFICode s : ffiParse ss
110−
111−
112− ffiError :: [FFI] -> Maybe String
113− ffiError [] = Nothing
114− ffiError ((FFIError s):xs) = Just s
115− ffiError (x:xs) = ffiError xs
116−
117−
118− renderFFI :: [FFI] -> [String] -> T.Text
119− renderFFI [] _ = ""
120− renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
121− renderFFI (FFIArg i : fs) args
122− | i < length args && i >= 0 =
123− T.pack (args !! i)
124− `T.append` renderFFI fs args
125− | otherwise = error "FFI - Argument index out of bounds"
126−
127−compileJS :: JS -> T.Text
128−compileJS = compileJS' 0
129−
130−compileJS' :: Int -> JS -> T.Text
131−compileJS' indent JSNoop = ""
132−
133−compileJS' indent (JSAnnotation annotation js) =
134− "/** @"
135− `T.append` T.pack (show annotation)
136− `T.append` " */\n"
137− `T.append` compileJS' indent js
138−
139−compileJS' indent (JSDelete js) =
140− "delete " `T.append` compileJS' 0 js
141−
142−compileJS' indent (JSClear js) =
143− compileJS' 0 js `T.append` " = undefined"
144−
145−compileJS' indent (JSFFI raw args) =
146− ffi raw (map (T.unpack . compileJS' indent) args)
147−
148−compileJS' indent (JSRaw code) =
149− T.pack code
150−
151−compileJS' indent (JSIdent ident) =
152− T.pack ident
153−
154−compileJS' indent (JSFunction args body) =
155− T.replicate indent " " `T.append` "function("
156− `T.append` T.intercalate "," (map T.pack args)
157− `T.append` "){\n"
158− `T.append` compileJS' (indent + 2) body
159− `T.append` "\n}\n"
160−
161−compileJS' indent (JSType ty)
162− | JSIntTy <- ty = "i$Int"
163− | JSStringTy <- ty = "i$String"
164− | JSIntegerTy <- ty = "i$Integer"
165− | JSFloatTy <- ty = "i$Float"
166− | JSCharTy <- ty = "i$Char"
167− | JSPtrTy <- ty = "i$Ptr"
168− | JSForgotTy <- ty = "i$Forgot"
169−
170−compileJS' indent (JSSeq seq) =
171− T.intercalate ";\n" (
172− map (
173− (T.replicate indent " " `T.append`) . (compileJS' indent)
174− ) $ filter (/= JSNoop) seq
175− ) `T.append` ";"
176−
177−compileJS' indent (JSReturn val) =
178− "return " `T.append` compileJS' indent val
179−
180−compileJS' indent (JSApp lhs rhs)
181− | JSFunction {} <- lhs =
182− T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
183− | otherwise =
184− T.concat [compileJS' indent lhs, "(", args, ")"]
185− where args :: T.Text
186− args = T.intercalate "," $ map (compileJS' 0) rhs
187−
188−compileJS' indent (JSNew name args) =
189− "new "
190− `T.append` T.pack name
191− `T.append` "("
192− `T.append` T.intercalate "," (map (compileJS' 0) args)
193− `T.append` ")"
194−
195−compileJS' indent (JSError exc) =
196− "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
197−
198−compileJS' indent (JSBinOp op lhs rhs) =
199− compileJS' indent lhs
200− `T.append` " "
201− `T.append` T.pack op
202− `T.append` " "
203− `T.append` compileJS' indent rhs
204−
205−compileJS' indent (JSPreOp op val) =
206− T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"
207−
208−compileJS' indent (JSProj obj field)
209− | JSFunction {} <- obj =
210− T.concat ["(", compileJS' indent obj, ").", T.pack field]
211− | JSAssign {} <- obj =
212− T.concat ["(", compileJS' indent obj, ").", T.pack field]
213− | otherwise =
214− compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
10+module IRTS.JavaScript.AST( JsAST(..)
11+ , jsAst2Text
12+ , js_aux_defs
13+ ) where
21514
216−compileJS' indent JSNull =
217− "null"
218−
219−compileJS' indent JSUndefined =
220− "undefined"
221−
222−compileJS' indent JSThis =
223− "this"
224−
225−compileJS' indent JSTrue =
226− "true"
227−
228−compileJS' indent JSFalse =
229− "false"
230−
231−compileJS' indent (JSArray elems) =
232− "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
233−
234−compileJS' indent (JSString str) =
235− "\"" `T.append` T.pack str `T.append` "\""
236−
237−compileJS' indent (JSNum num)
238− | JSInt i <- num = T.pack (show i)
239− | JSFloat f <- num = T.pack (show f)
240− | JSInteger JSBigZero <- num = T.pack "i$ZERO"
241− | JSInteger JSBigOne <- num = T.pack "i$ONE"
242− | JSInteger (JSBigInt i) <- num = T.pack (show i)
243− | JSInteger (JSBigIntExpr e) <- num =
244− "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
245−
246−compileJS' indent (JSAssign lhs rhs) =
247− compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
248−
249−compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
250− "var "
251− `T.append` T.pack name
252− `T.append` " = "
253− `T.append` compileJS' 0 val
254− `T.append` ";\n"
255−
256−compileJS' indent (JSAlloc name val) =
257− "var "
258− `T.append` T.pack name
259− `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
260−
261−compileJS' indent (JSIndex lhs rhs) =
262− compileJS' indent lhs
263− `T.append` "["
264− `T.append` compileJS' indent rhs
265− `T.append` "]"
266−
267−compileJS' indent (JSCond branches) =
268− T.intercalate " else " $ map createIfBlock branches
269− where
270− createIfBlock (JSNoop, e@(JSSeq _)) =
271− "{\n"
272− `T.append` compileJS' (indent + 2) e
273− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
274− createIfBlock (JSNoop, e) =
275− "{\n"
276− `T.append` compileJS' (indent + 2) e
277− `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
278− createIfBlock (cond, e@(JSSeq _)) =
279− "if (" `T.append` compileJS' indent cond `T.append`") {\n"
280− `T.append` compileJS' (indent + 2) e
281− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
282− createIfBlock (cond, e) =
283− "if (" `T.append` compileJS' indent cond `T.append`") {\n"
284− `T.append` T.replicate (indent + 2) " "
285− `T.append` compileJS' (indent + 2) e
286− `T.append` ";\n"
287− `T.append` T.replicate indent " "
288− `T.append` "}"
289−
290−compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
291− let (h,t) = splitAt 1 seq in
292− (T.concat (map (compileJS' indent) h) `T.append` ";\n")
293− `T.append` (
294− T.intercalate ";\n" $ map (
295− (T.replicate indent " " `T.append`) . compileJS' indent
296− ) t
297− )
298−
299−compileJS' indent (JSSwitch val branches def) =
300− "switch(" `T.append` compileJS' indent val `T.append` "){\n"
301− `T.append` T.concat (map mkBranch branches)
302− `T.append` mkDefault def
303− `T.append` T.replicate indent " " `T.append` "}"
304− where
305− mkBranch :: (JS, JS) -> T.Text
306− mkBranch (tag, code) =
307− T.replicate (indent + 2) " "
308− `T.append` "case "
309− `T.append` compileJS' indent tag
310− `T.append` ":\n"
311− `T.append` compileJS' (indent + 4) code
312− `T.append` "\n"
313− `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
314−
315− mkDefault :: Maybe JS -> T.Text
316− mkDefault Nothing = ""
317− mkDefault (Just def) =
318− T.replicate (indent + 2) " " `T.append` "default:\n"
319− `T.append` compileJS' (indent + 4)def
320− `T.append` "\n"
321−
322−
323−compileJS' indent (JSTernary cond true false) =
324− let c = compileJS' indent cond
325− t = compileJS' indent true
326− f = compileJS' indent false in
327− "("
328− `T.append` c
329− `T.append` ")?("
330− `T.append` t
331− `T.append` "):("
332− `T.append` f
333− `T.append` ")"
334−
335−compileJS' indent (JSParens js) =
336− "(" `T.append` compileJS' indent js `T.append` ")"
337−
338−compileJS' indent (JSWhile cond body) =
339− "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
340− `T.append` compileJS' (indent + 2) body
341− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
342−
343−compileJS' indent (JSWord word)
344− | JSWord8 b <- word =
345− "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
346− | JSWord16 b <- word =
347− "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
348− | JSWord32 b <- word =
349− "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
350− | JSWord64 b <- word =
351− "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
352−
353−jsInstanceOf :: JS -> String -> JS
354−jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
355−
356−jsOr :: JS -> JS -> JS
357−jsOr lhs rhs = JSBinOp "||" lhs rhs
358−
359−jsAnd :: JS -> JS -> JS
360−jsAnd lhs rhs = JSBinOp "&&" lhs rhs
361−
362−jsMeth :: JS -> String -> [JS] -> JS
363−jsMeth obj meth args = JSApp (JSProj obj meth) args
364−
365−jsCall :: String -> [JS] -> JS
366−jsCall fun args = JSApp (JSIdent fun) args
367−
368−jsTypeOf :: JS -> JS
369−jsTypeOf js = JSPreOp "typeof " js
370−
371−jsEq :: JS -> JS -> JS
372−jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
373−jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
374−jsEq lhs rhs = JSBinOp "==" lhs rhs
375−
376−jsNotEq :: JS -> JS -> JS
377−jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
378−
379−jsIsNumber :: JS -> JS
380−jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
381−
382−jsIsNull :: JS -> JS
383−jsIsNull js = JSBinOp "==" js JSNull
384−
385−jsBigInt :: JS -> JS
386−jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
387−jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
388−jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
389−
390−jsUnPackBits :: JS -> JS
391−jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
392−
393−jsPackUBits8 :: JS -> JS
394−jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
395−
396−jsPackUBits16 :: JS -> JS
397−jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
398−
399−jsPackUBits32 :: JS -> JS
400−jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
401−
402−jsPackSBits8 :: JS -> JS
403−jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
404−
405−jsPackSBits16 :: JS -> JS
406−jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
407−
408−jsPackSBits32 :: JS -> JS
409−jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import Data.Data
18+
19+data JsAST = JsEmpty
20+ | JsNull
21+ | JsLambda [Text] JsAST
22+ | JsFun Text [Text] JsAST
23+ | JsCurryFun Text [Text] JsAST
24+ | JsReturn JsAST
25+ | JsApp Text [JsAST]
26+ | JsCurryApp JsAST [JsAST]
27+ | JsMethod JsAST Text [JsAST]
28+ | JsVar Text
29+ | JsSeq JsAST JsAST
30+ | JsDecVar Text JsAST
31+ | JsSetVar Text JsAST
32+ | JsArrayProj JsAST JsAST
33+ | JsInt Int
34+ | JsInteger Integer
35+ | JsDouble Double
36+ | JsStr Text
37+ | JsArray [JsAST]
38+ | JsSwitchCase JsAST [(JsAST, JsAST)] (Maybe JsAST)
39+ | JsError JsAST
40+ | JsErrorExp JsAST
41+ | JsBinOp Text JsAST JsAST
42+ | JsForeign Text [JsAST]
43+ | JsB2I JsAST
44+ | JsWhileTrue JsAST
45+ | JsContinue
46+ | JsBreak
47+ | JsComment Text
48+ | JsForce JsAST
49+ | JsLazy JsAST
50+ deriving (Show, Eq, Data, Typeable)
51+
52+
53+indent :: Text -> Text
54+indent x =
55+ let l = T.lines x
56+ il = map (\y -> T.replicate 3 " " `T.append` y) l
57+ in T.unlines il
58+
59+curryDef :: [Text] -> JsAST -> Text
60+curryDef [] body =
61+ jsAst2Text body
62+curryDef (x:xs) body =
63+ T.concat [ "return function", "(", x, "){\n"
64+ , indent $ curryDef xs body
65+ , "}\n"
66+ ]
67+
68+
69+jsAst2Text :: JsAST -> Text
70+jsAst2Text JsEmpty = ""
71+jsAst2Text JsNull = "null"
72+jsAst2Text (JsLambda args body) =
73+ T.concat [ "(function", "(", T.intercalate ", " args , "){"
74+ , jsAst2Text body
75+ , "})"
76+ ]
77+jsAst2Text (JsFun name args body) =
78+ T.concat [ "function ", name, "(", T.intercalate ", " args , "){\n"
79+ , indent $ jsAst2Text body
80+ , "}\n"
81+ ]
82+jsAst2Text (JsCurryFun name args body) =
83+ T.concat [ "var ", name, " = \n"
84+ , indent $ T.concat [ "(function(){\n"
85+ , indent $ curryDef args body
86+ , "})()"
87+ ]
88+ ]
89+jsAst2Text (JsReturn x) = T.concat [ "return ", jsAst2Text x]
90+jsAst2Text (JsApp fn args) = T.concat [fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
91+jsAst2Text (JsCurryApp fn []) = jsAst2Text fn
92+jsAst2Text (JsCurryApp fn args) = T.concat [jsAst2Text fn, "(", T.intercalate ")(" $ map jsAst2Text args, ")"]
93+jsAst2Text (JsMethod obj name args) =
94+ T.concat [ jsAst2Text obj
95+ , "."
96+ , name, "("
97+ , T.intercalate ", " $ map jsAst2Text args
98+ , ")"
99+ ]
100+jsAst2Text (JsVar x) = x
101+jsAst2Text (JsSeq JsEmpty y) = jsAst2Text y
102+jsAst2Text (JsSeq x JsEmpty) = jsAst2Text x
103+jsAst2Text (JsSeq x y) = T.concat [jsAst2Text x, ";\n", jsAst2Text y]
104+jsAst2Text (JsDecVar name exp) = T.concat [ "var ", name, " = ", jsAst2Text exp]
105+jsAst2Text (JsSetVar name exp) = T.concat [ name, " = ", jsAst2Text exp]
106+jsAst2Text (JsArrayProj i exp) = T.concat [ jsAst2Text exp, "[", jsAst2Text i, "]"]
107+jsAst2Text (JsInt i) = T.pack $ show i
108+jsAst2Text (JsDouble d) = T.pack $ show d
109+jsAst2Text (JsInteger i) = T.pack $ show i
110+jsAst2Text (JsStr s) = T.pack $ show s
111+jsAst2Text (JsArray l) = T.concat [ "[", T.intercalate ", " (map jsAst2Text l), "]"]
112+jsAst2Text (JsSwitchCase exp l d) =
113+ T.concat [ "switch(", jsAst2Text exp, "){\n"
114+ , indent $ T.concat $ map case2Text l
115+ , indent $ default2Text d
116+ , "}\n"
117+ ]
118+jsAst2Text (JsError t) =
119+ T.concat ["throw new Error( ", jsAst2Text t, ")"]
120+jsAst2Text (JsErrorExp t) =
121+ T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"]
122+jsAst2Text (JsBinOp op a1 a2) =
123+ T.concat ["(", jsAst2Text a1," ", op, " ",jsAst2Text a2, ")"]
124+jsAst2Text (JsForeign code args) =
125+ let args_repl c i [] = c
126+ args_repl c i (t:r) = args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i+1) r
127+ in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]
128+jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)
129+jsAst2Text (JsWhileTrue x) =
130+ T.concat [ "while(true){\n"
131+ , indent $ jsAst2Text x
132+ , "}\n"
133+ ]
134+jsAst2Text JsContinue =
135+ "continue"
136+jsAst2Text JsBreak =
137+ "break"
138+jsAst2Text (JsComment c)=
139+ T.concat ["/*",c,"*/"]
140+jsAst2Text (JsLazy e) =
141+ T.concat [ "{js_idris_lazy_calc:function(){"
142+ , indent $ jsAst2Text e
143+ , "}}"
144+ ]
145+jsAst2Text (JsForce e) =
146+ T.concat ["js_idris_force(", jsAst2Text e, ")"]
147+
148+
149+
150+case2Text :: (JsAST, JsAST) -> Text
151+case2Text (x,y) =
152+ T.concat [ "case ", jsAst2Text x, ":\n"
153+ , indent $ T.concat [ jsAst2Text y, ";\nbreak;\n"]
154+ ]
155+
156+throw2 = T.concat [ "var js_idris_throw2 = function (x){\n"
157+ , " throw x;\n"
158+ , "}\n\n"
159+ ]
160+
161+force = T.concat [ "var js_idris_force = function (x){\n"
162+ , " if(x.js_idris_lazy_calc === undefined){\n"
163+ , " return x\n"
164+ , " }else{\n"
165+ , " if(x.js_idris_lazy_val === undefined){\n"
166+ , " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n"
167+ , " }"
168+ , " return x.js_idris_lazy_val"
169+ , "}"
170+ , "}\n\n"
171+ ]
172+
173+js_aux_defs = T.concat [throw2, force]
174+
175+default2Text :: Maybe JsAST -> Text
176+default2Text Nothing = ""
177+default2Text (Just z) =
178+ T.concat [ "default:\n"
179+ , indent $ T.concat [ jsAst2Text z, ";\nbreak;\n"]
180+ ]
src/IRTS/JavaScript/Codegen.hsnew file+367
@@ -0,0 +1,367 @@
1+{-|
2+Module : IRTS.JavaScript.Codegen
3+Description : The JavaScript common code generator.
4+Copyright :
5+License : BSD3
6+Maintainer : The Idris Community.
7+-}
8+{-# LANGUAGE OverloadedStrings #-}
9+
10+module IRTS.JavaScript.Codegen( codegenJs
11+ , CGConf(..)
12+ , CGStats(..)
13+ ) where
14+
15+import Control.DeepSeq
16+import IRTS.CodegenCommon
17+import IRTS.Lang
18+import Idris.Core.TT
19+import IRTS.LangOpts
20+
21+import IRTS.JavaScript.AST
22+import IRTS.JavaScript.LangTransforms
23+
24+import Data.Maybe (fromJust)
25+import Data.Text (Text)
26+import qualified Data.Text as T
27+import qualified Data.Text.IO as TIO
28+import Data.Char
29+import Data.Set (Set)
30+import qualified Data.Set as Set
31+import Data.Map.Strict (Map)
32+import qualified Data.Map.Strict as Map
33+import Data.List (nub)
34+import System.Directory (doesFileExist)
35+import System.FilePath (combine)
36+import Control.Monad.Trans.State
37+import System.Environment
38+
39+import GHC.Generics (Generic)
40+import Data.Data
41+import Data.Generics.Uniplate.Data
42+import Data.List
43+
44+data CGStats = CGStats { usedWriteStr :: Bool
45+ }
46+
47+emptyStats :: CGStats
48+emptyStats = CGStats {usedWriteStr = False}
49+
50+data CGConf = CGConf { header :: Text
51+ , initialization :: CGStats -> Text
52+ , writeStrTemplate :: Text
53+ }
54+
55+
56+get_include :: FilePath -> IO Text
57+get_include p = TIO.readFile p
58+
59+get_includes :: [FilePath] -> IO Text
60+get_includes l = do
61+ incs <- mapM get_include l
62+ return $ T.intercalate "\n\n" incs
63+
64+isYes :: Maybe String -> Bool
65+isYes (Just "Y") = True
66+isYes (Just "y") = True
67+isYes _ = False
68+
69+
70+codegenJs :: CGConf -> CodeGenerator
71+codegenJs conf ci =
72+ do
73+ optim <- isYes <$> lookupEnv "IDRISJS_OPTIM"
74+ debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
75+ if debug then
76+ if optim then putStrLn "compiling width idris-js optimizations"
77+ else putStrLn "compiling widthout idris-js optimizations"
78+ else pure ()
79+ let defs = addAlist (liftDecls ci) emptyContext
80+ let used = used_decls defs [sMN 0 "runMain"]
81+ used `deepseq` if debug then
82+ do
83+ putStrLn $ "Finished calculating used"
84+ writeFile (outputFile ci ++ ".LDecls") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
85+ else pure ()
86+
87+ let (out, stats) = doCodegen conf defs used --T.intercalate "\n" $ map (doCodegen conf defs) used
88+ out `deepseq` if debug then putStrLn $ "Finished generating code" else pure ()
89+ includes <- get_includes $ includes ci
90+ TIO.writeFile (outputFile ci) $ T.concat [ header conf
91+ , "\"use strict\";\n\n"
92+ , "(function(){\n\n"
93+ , initialization conf stats
94+ , includes, "\n"
95+ , js_aux_defs, "\n"
96+ , out, "\n"
97+ , "\n\n"
98+ , "\n}())"
99+ ]
100+
101+jsName :: Name -> Text
102+jsName n = T.pack $ "idris_" ++ concatMap jschar (showCG n)
103+ where jschar x | isAlpha x || isDigit x = [x]
104+ | otherwise = "_" ++ show (fromEnum x) ++ "_"
105+
106+doCodegen :: CGConf -> LDefs -> [LDecl] -> (Text, CGStats)
107+doCodegen conf defs decls =
108+ let xs = map (doCodegenDecl conf defs) decls
109+ groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y}
110+ in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
111+
112+doCodegenDecl :: CGConf -> LDefs -> LDecl -> (Text, CGStats)
113+doCodegenDecl conf defs (LFun _ n args def) =
114+ let (ast, stats) = cgFun conf defs n args def
115+ in (jsAst2Text $ ast, stats)
116+doCodegenDecl conf defs (LConstructor n i sz) =
117+ ("", emptyStats)
118+
119+seqJs :: [JsAST] -> JsAST
120+seqJs [] = JsEmpty
121+seqJs (x:xs) = JsSeq x (seqJs xs)
122+
123+data CGBodyState = CGBodyState { defs :: LDefs
124+ , lastIntName :: Int
125+ , currentFnNameAndArgs :: (Text, [Text])
126+ , isTailRec :: Bool
127+ , conf :: CGConf
128+ , usedWrite :: Bool
129+ }
130+
131+getNewCGName :: State CGBodyState Text
132+getNewCGName =
133+ do
134+ st <- get
135+ let v = lastIntName st + 1
136+ put $ st {lastIntName = v}
137+ return $ T.pack $ "cgIdris_" ++ show v
138+
139+getConsId :: Name -> State CGBodyState Int
140+getConsId n =
141+ do
142+ st <- get
143+ case lookupCtxtExact n (defs st) of
144+ Just (LConstructor _ conId _) -> pure conId
145+ _ -> error $ "ups " ++ showCG n
146+
147+
148+data BodyResTarget = ReturnBT
149+ | DecVarBT Text
150+ | SetVarBT Text
151+ | GetExpBT
152+
153+cgFun :: CGConf -> LDefs -> Name -> [Name] -> LExp -> (JsAST, CGStats)
154+cgFun cnf dfs n args def =
155+ let
156+ fnName = jsName n
157+ argNames = map jsName args
158+ ((decs, res),st) = runState
159+ (cgBody ReturnBT def)
160+ (CGBodyState { defs=dfs
161+ , lastIntName = 0
162+ , currentFnNameAndArgs = (fnName, argNames)
163+ , isTailRec = False
164+ , conf = cnf
165+ , usedWrite = False
166+ }
167+ )
168+ body = if isTailRec st then JsWhileTrue $ (seqJs decs) `JsSeq` res `JsSeq` JsBreak
169+ else JsSeq (seqJs decs) res
170+ in (JsCurryFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st})
171+
172+getSwitchJs :: JsAST -> [LAlt] -> JsAST
173+getSwitchJs x alts =
174+ if any conCase alts then JsArrayProj (JsInt 0) x
175+ else x
176+ where conCase (LConCase _ _ _ _) = True
177+ conCase _ = False
178+
179+addRT :: BodyResTarget -> JsAST -> JsAST
180+addRT ReturnBT x = JsReturn x
181+addRT (DecVarBT n) x = JsDecVar n x
182+addRT (SetVarBT n) x = JsSetVar n x
183+addRT GetExpBT x = x
184+
185+cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsAST], JsAST)
186+cgBody rt (LV (Glob n)) =
187+ pure $ ([], addRT rt $ JsVar $ jsName n)
188+cgBody rt (LApp _ (LV (Glob fn)) args) =
189+ do
190+ let fname = jsName fn
191+ st <- get
192+ let (currFn, argN) = currentFnNameAndArgs st
193+ z <- mapM (cgBody GetExpBT) args
194+ let preDecs = concat $ map fst z
195+ case (fname == currFn, rt) of
196+ (True, ReturnBT) ->
197+ do
198+ put $ st {isTailRec = True}
199+ vars <- sequence $ map (\_->getNewCGName) argN
200+ let calcs = map (\(n,v) -> JsDecVar n v) (zip vars (map snd z))
201+ let calcsToArgs = map (\(n,v) -> JsSetVar n (JsVar v)) (zip argN vars)
202+ pure (preDecs ++ calcs ++ calcsToArgs, JsContinue)
203+ _ ->
204+ pure $ (preDecs, addRT rt $ JsCurryApp (JsVar fname) (map snd z))
205+cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
206+cgBody rt (LLazyApp n args) =
207+ do
208+ (d,v) <- cgBody ReturnBT (LApp False (LV (Glob n)) args)
209+ pure ([], addRT rt $ JsLazy $ JsSeq (seqJs d) v)
210+cgBody rt (LForce e) =
211+ do
212+ (d,v) <- cgBody GetExpBT e
213+ pure (d, addRT rt $ JsForce v)
214+cgBody rt (LLet n v sc) =
215+ do
216+ (d1, v1) <- cgBody (DecVarBT $ jsName n) v
217+ (d2, v2) <- cgBody rt sc
218+ pure $ ((d1 ++ v1 : d2), v2 )
219+cgBody rt (LProj e i) =
220+ do
221+ (d, v) <- cgBody GetExpBT e
222+ pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ v)
223+cgBody rt (LCon _ conId n args) =
224+ do
225+ z <- mapM (cgBody GetExpBT) args
226+ pure $ (concat $ map fst z, addRT rt $ JsArray (JsInt conId : map snd z))
227+cgBody rt (LCase _ e alts) =
228+ do
229+ (d,v) <- cgBody GetExpBT e
230+ resName <- getNewCGName
231+ swName <- getNewCGName
232+ (altsJs,def) <- cgAlts rt resName (JsVar swName) alts
233+ let decSw = JsDecVar swName v
234+ let sw = JsSwitchCase (getSwitchJs (JsVar swName) alts) altsJs def
235+ case rt of
236+ ReturnBT ->
237+ pure (d ++ [decSw], sw)
238+ (DecVarBT nvar) ->
239+ pure (d ++ [decSw, JsDecVar nvar JsNull], sw)
240+ (SetVarBT nvar) ->
241+ pure (d ++ [decSw], sw)
242+ GetExpBT ->
243+ pure (d ++ [decSw, JsDecVar resName JsNull, sw], JsVar resName)
244+cgBody rt (LConst c) = pure ([], (addRT rt) $ cgConst c)
245+cgBody rt (LOp op args) =
246+ do
247+ z <- mapM (cgBody GetExpBT) args
248+ res <- cgOp op (map snd z)
249+ pure $ (concat $ map fst z, addRT rt $ res)
250+cgBody rt LNothing = pure ([], addRT rt JsNull)
251+cgBody rt (LError x) = pure ([JsError $ JsStr $ T.pack $ x], addRT rt JsNull)
252+cgBody rt x@(LForeign dres (FStr code) args ) =
253+ do
254+ z <- mapM (cgBody GetExpBT) (map snd args)
255+ let jsArgs = map cgForeignArg (zip (map fst args) (map snd z))
256+ pure $ (concat $ map fst z, addRT rt $ cgForeignRes dres $ JsForeign (T.pack code) jsArgs)
257+cgBody _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
258+
259+replaceMatchVars :: JsAST -> Map Text Int -> JsAST -> JsAST
260+replaceMatchVars n d z =
261+ transform f z
262+ where
263+ f :: JsAST -> JsAST
264+ f (JsVar x) =
265+ case Map.lookup x d of
266+ Nothing -> (JsVar x)
267+ Just i -> JsArrayProj (JsInt i) n
268+ f x = x
269+
270+altsRT :: Text -> BodyResTarget -> BodyResTarget
271+altsRT rn ReturnBT = ReturnBT
272+altsRT rn (DecVarBT n) = SetVarBT n
273+altsRT rn (SetVarBT n) = SetVarBT n
274+altsRT rn GetExpBT = SetVarBT rn
275+
276+cgAlts :: BodyResTarget -> Text -> JsAST -> [LAlt] -> State CGBodyState ([(JsAST, JsAST)], Maybe JsAST)
277+cgAlts rt resName scrvar ((LConstCase t exp):r) =
278+ do
279+ (d, v) <- cgBody (altsRT resName rt) exp
280+ (ar, def) <- cgAlts rt resName scrvar r
281+ pure ((cgConst t, JsSeq (seqJs d) v) : ar, def)
282+cgAlts rt resName scrvar ((LDefaultCase exp):r) =
283+ do
284+ (d, v) <- cgBody (altsRT resName rt) exp
285+ pure ([], Just $ JsSeq (seqJs d) v)
286+cgAlts rt resName scrvar ((LConCase _ n args exp):r) =
287+ do
288+ (d, v) <- cgBody (altsRT resName rt) exp
289+ (ar, def) <- cgAlts rt resName scrvar r
290+ conId <- getConsId n
291+ -- let branchBody = JsSeq (conCaseToProjs 1 scrvar args) $ JsSeq (seqJs d) v
292+ let replace = replaceMatchVars scrvar (Map.fromList $ zip (map jsName args) [1..])
293+ let branchBody = JsSeq (seqJs $ map replace d) (replace v)
294+ pure ((JsInt conId, branchBody) : ar, def)
295+cgAlts _ _ _ [] =
296+ pure ([],Nothing)
297+
298+
299+cgForeignArg :: (FDesc, JsAST) -> JsAST
300+cgForeignArg (FApp (UN "JS_IntT") _, v) = v
301+cgForeignArg (FCon (UN "JS_Str"), v) = v
302+cgForeignArg (FCon (UN "JS_Ptr"), v) = v
303+cgForeignArg (FCon (UN "JS_Unit"), v) = v
304+cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =
305+ f
306+cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =
307+ JsLambda ["x"] $ JsReturn $ cgForeignRes b $ JsCurryApp (JsCurryApp f [cgForeignArg (a, JsVar "x")]) [JsNull]
308+cgForeignArg (desc, _) = error $ "Foreign arg type " ++ show desc ++ " not supported yet."
309+
310+cgForeignRes :: FDesc -> JsAST -> JsAST
311+cgForeignRes (FApp (UN "JS_IntT") _) x = x
312+cgForeignRes (FCon (UN "JS_Unit")) x = x
313+cgForeignRes (FCon (UN "JS_Str")) x = x
314+cgForeignRes (FCon (UN "JS_Ptr")) x = x
315+cgForeignRes (FCon (UN "JS_Float")) x = x
316+cgForeignRes desc val = error $ "Foreign return type " ++ show desc ++ " not supported yet."
317+
318+cgConst :: Const -> JsAST
319+cgConst (I i) = JsInt i
320+cgConst (BI i) = JsInteger i
321+cgConst (Ch c) = JsInt $ ord c
322+cgConst (Str s) = JsStr $ T.pack s
323+cgConst (Fl f) = JsDouble f
324+cgConst (B8 x) = error "error B8"
325+cgConst (B16 x) = error "error B16"
326+cgConst (B32 x) = error "error B32"
327+cgConst (B64 x) = error "error B64"
328+cgConst x | isTypeConst x = JsInt 0
329+cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
330+
331+cgOp :: PrimFn -> [JsAST] -> State CGBodyState JsAST
332+cgOp (LPlus _) [l, r] = pure $ JsBinOp "+" l r
333+cgOp (LMinus _) [l, r] = pure $ JsBinOp "-" l r
334+cgOp (LTimes _) [l, r] = pure $ JsBinOp "*" l r
335+cgOp (LEq _) [l, r] = pure $ JsB2I $ JsBinOp "==" l r
336+cgOp (LSLt _) [l, r] = pure $ JsB2I $ JsBinOp "<" l r
337+cgOp (LSLe _) [l, r] = pure $ JsB2I $ JsBinOp "<=" l r
338+cgOp (LSGt _) [l, r] = pure $ JsB2I $ JsBinOp ">" l r
339+cgOp (LSGe _) [l, r] = pure $ JsB2I $ JsBinOp ">=" l r
340+cgOp LStrEq [l,r] = pure $ JsB2I $ JsBinOp "==" l r
341+cgOp LStrLen [x] = pure $ JsForeign "%0.length" [x]
342+cgOp LStrHead [x] = pure $ JsMethod x "charCodeAt" [JsInt 0]
343+cgOp LStrIndex [x, y] = pure $ JsMethod x "charCodeAt" [y]
344+cgOp LStrTail [x] = pure $ JsMethod x "slice" [JsInt 1]
345+cgOp LStrLt [l, r] = pure $ JsB2I $ JsBinOp "<" l r
346+cgOp (LFloatStr) [x] = pure $ JsBinOp "+" x (JsStr "")
347+cgOp (LIntStr _) [x] = pure $ JsBinOp "+" x (JsStr "")
348+cgOp (LFloatInt _) [x] = pure $ JsApp "Math.trunc" [x]
349+cgOp (LStrInt _) [x] = pure $ JsBinOp "||" (JsApp "parseInt" [x]) (JsInt 0)
350+cgOp (LStrFloat) [x] = pure $ JsBinOp "||" (JsApp "parseFloat" [x]) (JsInt 0)
351+cgOp (LChInt _) [x] = pure $ x
352+cgOp (LIntCh _) [x] = pure $ x
353+cgOp (LSExt _ _) [x] = pure $ x
354+cgOp (LZExt _ _) [x] = pure $ x
355+cgOp (LIntFloat _) [x] = pure $ x
356+cgOp (LSDiv _) [x,y] = pure $ JsBinOp "/" x y
357+cgOp LWriteStr [_,str] =
358+ do
359+ s <- get
360+ put $ s {usedWrite = True}
361+ pure $ JsForeign (writeStrTemplate $ conf s) [str]
362+ --pure $ JsApp "console.log" [str]
363+cgOp LStrConcat [l,r] = pure $ JsBinOp "+" l r
364+cgOp LStrCons [l,r] = pure $ JsForeign "String.fromCharCode(%0) + %1" [l,r]
365+cgOp (LSRem (ATInt _)) [l,r] = pure $ JsBinOp "%" l r
366+cgOp LCrash [l] = pure $ JsErrorExp l
367+cgOp op exps = error ("Operator " ++ show (op, exps) ++ " not implemented")
src/IRTS/JavaScript/LangTransforms.hsnew file+111
@@ -0,0 +1,111 @@
1+{-|
2+Module : IRTS.JavaScript.LangTransforms
3+Description : The JavaScript LDecl Transformations.
4+Copyright :
5+License : BSD3
6+Maintainer : The Idris Community.
7+-}
8+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, OverloadedStrings, DeriveGeneric, DeriveAnyClass, FlexibleInstances #-}
9+
10+module IRTS.JavaScript.LangTransforms( used_decls
11+ ) where
12+
13+
14+import Control.DeepSeq
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import Data.Set (Set)
18+import qualified Data.Set as Set
19+import Data.Map.Strict (Map)
20+import qualified Data.Map.Strict as Map
21+import Idris.Core.TT
22+import IRTS.Lang
23+import Idris.Core.CaseTree
24+import Data.List
25+import Data.Maybe
26+import Control.Monad.Trans.State
27+
28+import GHC.Generics (Generic)
29+import Data.Data
30+import Data.Generics.Uniplate.Data
31+import Idris.Core.DeepSeq
32+
33+deriving instance Typeable (LAlt' LExp)
34+deriving instance Data (LAlt' LExp)
35+deriving instance Typeable FDesc
36+deriving instance Data FDesc
37+deriving instance Typeable LVar
38+deriving instance Data LVar
39+deriving instance Typeable PrimFn
40+deriving instance Data PrimFn
41+deriving instance Typeable CaseType
42+deriving instance Data CaseType
43+deriving instance Typeable LExp
44+deriving instance Data LExp
45+deriving instance Typeable LDecl
46+deriving instance Data LDecl
47+deriving instance Typeable LOpt
48+deriving instance Data LOpt
49+
50+deriving instance Generic LDecl
51+deriving instance NFData LDecl
52+deriving instance Generic LOpt
53+deriving instance NFData LOpt
54+deriving instance Generic LExp
55+deriving instance NFData LExp
56+deriving instance NFData PrimFn
57+deriving instance Generic LVar
58+deriving instance NFData LVar
59+deriving instance NFData (LAlt' LExp)
60+deriving instance Generic (LAlt' e)
61+deriving instance NFData FDesc
62+deriving instance Generic FDesc
63+
64+{-
65+deriving instance NFData FC
66+deriving instance NFData FC'
67+deriving instance NFData SpecialName
68+deriving instance NFData Name
69+deriving instance NFData ArithTy
70+deriving instance NFData IntTy
71+deriving instance NFData NativeTy
72+deriving instance NFData Const
73+deriving instance NFData CaseType
74+-}
75+
76+
77+restrictKeys :: Ord k => Map k a -> Set k -> Map k a
78+restrictKeys m s = Map.filterWithKey (\k _ -> k `Set.member` s) m
79+
80+mapMapListKeys :: Ord k => (a->a) -> [k] -> Map k a -> Map k a
81+mapMapListKeys _ [] x = x
82+mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x
83+
84+memberCtx :: Name -> Ctxt a -> Bool
85+memberCtx n ctx =
86+ case lookupCtxtExact n ctx of
87+ Nothing -> False
88+ Just _ -> True
89+
90+
91+extract_globs :: LDefs -> LDecl -> [Name]
92+extract_globs defs (LConstructor _ _ _) = []
93+extract_globs defs (LFun _ _ _ e) =
94+ let f (LV (Glob x)) = Just x
95+ f (LLazyApp x _) = Just x
96+ f _ = Nothing
97+ in [x | Just x <- map f $ universe e, memberCtx x defs]
98+
99+used_functions :: LDefs -> Set Name -> [Name] -> [Name]
100+used_functions _ _ [] = []
101+used_functions alldefs done names =
102+ let decls = catMaybes $ map (\x -> lookupCtxtExact x alldefs) names
103+ used_names = (nub $ concat $ map (extract_globs alldefs) decls) \\ names
104+ new_names = filter (\x -> not $ Set.member x done) used_names
105+ in used_names ++ used_functions alldefs (Set.union done $ Set.fromList new_names) new_names
106+
107+
108+used_decls :: LDefs -> [Name] -> [LDecl]
109+used_decls dcls start =
110+ let used = reverse $ start ++ used_functions dcls (Set.fromList start) start
111+ in catMaybes $ map (\x -> lookupCtxtExact x dcls) used