ilyakooo0/Idris-dev
1
0
Fork 0
mirror of https://github.com/ilyakooo0/Idris-dev.git synced 2024-09-11 08:55:23 +03:00
Code Issues Projects Releases Wiki Activity

JSRTS: move templates into JSRTS

Browse Source
This commit is contained in:
be5invis 2017-05-24 21:44:03 +08:00
parent 9ed63a9989
commit 4f002e5dd6
9 changed files with 1395 additions and 1445 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
jsrts/Runtime-common.js
View File

@ -1,15 +1,22 @@
var js_idris_throw2 = function (x){
throw x;
}
var js_idris_force = function (x){
if(x === undefined || x.js_idris_lazy_calc === undefined){
return x
}else{
if(x.js_idris_lazy_val === undefined){
x.js_idris_lazy_val = x.js_idris_lazy_calc()
const $JSRTS = {
throw: function (x) {
throw x;
},
Lazy: function (e) {
this.js_idris_lazy_calc = e;
this.js_idris_lazy_val = void 0;
},
force: function (x) {
if (x === undefined || x.js_idris_lazy_calc === undefined) {
return x
} else {
if (x.js_idris_lazy_val === undefined) {
x.js_idris_lazy_val = x.js_idris_lazy_calc()
}
return x.js_idris_lazy_val
}
},
prim_strSubstr: function (offset, len, str) {
return str.slice(Math.max(0, offset), Math.max(0, len))
}
return x.js_idris_lazy_val
}
}
};

20
jsrts/Runtime-javascript.js
View File

@ -1,9 +1,11 @@
var js_idris_systemInfo = function(index) {
switch(index) {
case 0:
return "javascript";
case 1:
return navigator.platform;
}
return "";
}
$JSRTS.prim_systemInfo = function (index) {
switch (index) {
case 0:
return "javascript";
case 1:
return navigator.platform;
}
return "";
};
$JSRTS.prim_writeStr = function (x) { return console.log(x) }
$JSRTS.prim_readStr = function () { return prompt('Prelude.getLine') };

39
jsrts/Runtime-node.js
View File

@ -1,10 +1,31 @@
var js_idris_systemInfo = function(index) {
var os = require('os')
switch(index) {
case 0:
return "node";
case 1:
return os.platform();
$JSRTS.os = require('os');
$JSRTS.fs = require('fs');
$JSRTS.prim_systemInfo = function (index) {
switch (index) {
case 0:
return "node";
case 1:
return $JSRTS.os.platform();
}
return "";
}
return "";
};
$JSRTS.prim_writeStr = function (x) { return process.stdout.write(x) }
$JSRTS.prim_readStr = function () {
var ret = '';
var b = new Buffer(1024);
var i = 0;
while (true) {
$JSRTS.fs.readSync(0, b, i, 1)
if (b[i] == 10) {
ret = b.toString('utf8', 0, i);
break;
}
i++;
if (i == b.length) {
nb = new Buffer(b.length * 2);
b.copy(nb)
b = nb;
}
}
return ret;
};

2608
jsrts/jsbn/jsbn-browser.js
View File

File diff suppressed because it is too large Load Diff

2
jsrts/jsbn/jsbn-node.js
View File

@ -1 +1 @@
const jsbn = require('jsbn');
$JSRTS.jsbn = require('jsbn');

35
src/IRTS/CodegenJavaScript.hs
View File

@ -40,29 +40,6 @@ htmlFooter =
, "</html>"
]
nodeReadLine :: Text
nodeReadLine =
T.concat [ "var js_idris_readStr = function() {\n"
, " var ret = '';"
, " var b = new Buffer(1024);"
, " var i = 0;\n"
, " while(true) {\n"
, " fs.readSync(0, b, i, 1 )\n"
, " if (b[i] == 10) {\n"
, " ret = b.toString('utf8', 0, i);\n"
, " break;\n"
, " }\n"
, " i++;\n"
, " if (i == b.length) {\n"
, " nb = new Buffer (b.length*2);\n"
, " b.copy(nb)\n"
, " b = nb;\n"
, " }\n"
, " }\n"
, " return ret;\n"
, " };\n"
]
codegenJavaScript :: CodeGenerator
codegenJavaScript ci =
let (h, f) = if (map toLower $ takeExtension $ outputFile ci) == ".html" then
@ -70,29 +47,17 @@ codegenJavaScript ci =
else ("","")
in codegenJs (CGConf { header = h
, footer = f
, initialization = const ""
, writeStrTemplate = "console.log(%0)"
, readStrTemplate = "prompt('Prelude.getLine')"
, jsbnPath = "jsbn/jsbn-browser.js"
, extraRunTime = "Runtime-javascript.js"
}
)
ci
initializationNode :: CGStats -> Text
initializationNode x =
T.concat [ if usedWriteStr x || usedReadStr x then "var fs = require('fs');\n" else ""
, if usedReadStr x then nodeReadLine else ""
]
codegenNode :: CodeGenerator
codegenNode ci =
do
codegenJs (CGConf { header = "#!/usr/bin/env node\n"
, footer = ""
, initialization = initializationNode
, writeStrTemplate = "process.stdout.write(%0)"
, readStrTemplate = "js_idris_readStr()"
, jsbnPath = "jsbn/jsbn-browser.js"
, extraRunTime = "Runtime-node.js"
}

26
src/IRTS/JavaScript/AST.hs
View File

@ -17,7 +17,6 @@ module IRTS.JavaScript.AST
, jsCurryLam
, jsCurryApp
, jsAppN
, js_aux_defs
, jsExpr2Stmt
, jsStmt2Expr
, jsSetVar
@ -274,7 +273,7 @@ jsAst2Text (JsStr s) = "\"" `T.append` T.pack (concatMap translateChar s) `T.a
jsAst2Text (JsArray l) =
T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"]
jsAst2Text (JsErrorExp t) =
T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"]
T.concat ["$JSRTS.throw(new Error( ", jsAst2Text t, "))"]
jsAst2Text (JsBinOp op a1 a2) =
T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"]
jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"]
@ -284,29 +283,10 @@ jsAst2Text (JsForeign code args) =
args_repl (T.replace ("%" `T.append` T.pack (show i)) (T.concat ["(", t, ")"]) c) (i + 1) r
in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]
jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)
jsAst2Text (JsForce e) = T.concat ["js_idris_force(", jsAst2Text e, ")"]
jsAst2Text (JsForce e) = T.concat ["$JSRTS.force(", jsAst2Text e, ")"]
jsLazy :: JsExpr -> JsExpr
jsLazy e = JsObj [("js_idris_lazy_calc", (JsLambda [] $ JsReturn e))]
throw2 =
T.concat ["var js_idris_throw2 = function (x){\n", " throw x;\n", "}\n"]
force =
T.concat
[ "var js_idris_force = function (x){\n"
, " if(x.js_idris_lazy_calc === undefined){\n"
, " return x\n"
, " }else{\n"
, " if(x.js_idris_lazy_val === undefined){\n"
, " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n"
, " }\n"
, " return x.js_idris_lazy_val\n"
, " }\n"
, "}\n"
]
js_aux_defs = T.concat [throw2, force]
jsLazy e = JsNew (JsProp (JsVar "$JSRTS") "Lazy") [(JsLambda [] $ JsReturn e)]
jsExpr2Stmt :: JsExpr -> JsStmt
jsExpr2Stmt = JsExprStmt

53
src/IRTS/JavaScript/Codegen.hs
View File

@ -45,26 +45,19 @@ import Data.Generics.Uniplate.Data
import Data.List
import GHC.Generics (Generic)
data CGStats = CGStats { usedWriteStr :: Bool
, usedReadStr :: Bool
, usedBigInt :: Bool
data CGStats = CGStats { usedBigInt :: Bool
, partialApplications :: Set Partial
, hiddenClasses :: Set HiddenClass
}
emptyStats :: CGStats
emptyStats = CGStats { usedWriteStr = False
, partialApplications = Set.empty
emptyStats = CGStats { partialApplications = Set.empty
, hiddenClasses = Set.empty
, usedBigInt = False
, usedReadStr = False
}
data CGConf = CGConf { header :: Text
, footer :: Text
, initialization :: CGStats -> Text
, writeStrTemplate :: Text
, readStrTemplate :: Text
, jsbnPath :: String
, extraRunTime :: String
}
@ -115,17 +108,15 @@ codegenJs conf ci =
TIO.writeFile (outputFile ci) $ T.concat [ header conf
, "\"use strict\";\n\n"
, "(function(){\n\n"
, jsbn
, initialization conf stats
, doPartials (partialApplications stats)
, doHiddenClasses (hiddenClasses stats)
, includes, "\n"
, runtimeCommon, "\n"
, extraRT, "\n"
, jsbn, "\n"
, doPartials (partialApplications stats), "\n"
, doHiddenClasses (hiddenClasses stats), "\n"
, includes, "\n"
, out, "\n"
, "\n"
, jsName (sMN 0 "runMain"), "();\n\n"
, "\n}.call(this))"
, jsName (sMN 0 "runMain"), "();\n"
, "}.call(this))"
, footer conf
]
@ -153,11 +144,9 @@ doHiddenClasses x =
doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen conf defs decls =
let xs = map (doCodegenDecl conf defs) decls
groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y
, partialApplications = partialApplications x `Set.union` partialApplications y
groupCGStats x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
, hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
, usedBigInt = usedBigInt x || usedBigInt y
, usedReadStr = usedReadStr x || usedReadStr y
}
in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
@ -179,8 +168,6 @@ data CGBodyState = CGBodyState { defs :: Map Name LDecl
, usedArgsTailCallOptim :: Set (Text, Text)
, isTailRec :: Bool
, conf :: CGConf
, usedWrite :: Bool
, usedRead :: Bool
, usedITBig :: Bool
, partialApps :: Set Partial
, hiddenCls :: Set HiddenClass
@ -238,15 +225,13 @@ cgFun cnf dfs n args def = do
let argNames = map jsName args
let ((decs, res),st) = runState
(cgBody ReturnBT def)
(CGBodyState { defs=dfs
(CGBodyState { defs = dfs
, lastIntName = 0
, reWrittenNames = Map.empty
, currentFnNameAndArgs = (fnName, argNames)
, usedArgsTailCallOptim = Set.empty
, isTailRec = False
, conf = cnf
, usedWrite = False
, usedRead = False
, usedITBig = False
, partialApps = Set.empty
, hiddenCls = Set.empty
@ -254,11 +239,9 @@ cgFun cnf dfs n args def = do
)
let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
let fn = JsFun fnName argNames body
let state' = CGStats { usedWriteStr = usedWrite st
, partialApplications = partialApps st
let state' = CGStats { partialApplications = partialApps st
, hiddenClasses = hiddenCls st
, usedBigInt = usedITBig st
, usedReadStr = usedRead st
}
(fn, state')
@ -579,7 +562,7 @@ cgConst (I i) = pure $ JsInt i
cgConst (BI i) =
do
setUsedITBig
pure $ JsForeign "new jsbn.BigInteger(%0)" [JsStr $ show i]
pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)" [JsStr $ show i]
cgConst (Ch c) = pure $ JsStr [c]
cgConst (Str s) = pure $ JsStr s
cgConst (Fl f) = pure $ JsDouble f
@ -589,7 +572,7 @@ cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []
cgConst (B64 x) =
do
setUsedITBig
pure $ JsForeign "new jsbn.BigInteger(%0).and(new jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
cgConst x | isTypeConst x = pure $ JsInt 0
cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
@ -597,16 +580,6 @@ cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp = cgOp' PTAny
cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp' pt LReadStr [_] =
do
s <- get
put $ s {usedRead = True}
pure $ JsForeign (readStrTemplate $ conf s) []
cgOp' pt LWriteStr [_,str] =
do
s <- get
put $ s {usedWrite = True}
pure $ JsForeign (writeStrTemplate $ conf s) [str]
cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
cgOp' pt op exps = case Map.lookup op primDB of

22
src/IRTS/JavaScript/PrimOp.hs
View File

@ -43,7 +43,7 @@ primDB =
, item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"
, item (LPlus (ATInt ITBig)) True PTAny $ method "add"
, item (LPlus (ATInt (ITFixed IT64))) True PTAny $
\[l, r] -> JsForeign "%0.add(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
\[l, r] -> JsForeign "%0.add(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
, item (LMinus ATFloat) False PTAny $ binop "-"
, item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"
, item (LMinus (ATInt ITNative)) False PTAny $ JsForeign "%0-%1|0"
@ -52,7 +52,7 @@ primDB =
, item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"
, item (LMinus (ATInt ITBig)) True PTAny $ method "subtract"
, item (LMinus (ATInt (ITFixed IT64))) True PTAny $
\[l, r] -> JsForeign "%0.subtract(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
\[l, r] -> JsForeign "%0.subtract(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
, item (LTimes ATFloat) False PTAny $ binop "*"
, item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"
, item (LTimes (ATInt ITNative)) False PTAny $ JsForeign "%0*%1|0"
@ -61,7 +61,7 @@ primDB =
, item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"
, item (LTimes (ATInt ITBig)) True PTAny $ method "multiply"
, item (LTimes (ATInt (ITFixed IT64))) True PTAny $
\[l, r] -> JsForeign "%0.multiply(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
\[l, r] -> JsForeign "%0.multiply(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
, item (LUDiv (ITFixed IT8)) False PTAny $ JsForeign "%0 / %1"
, item (LUDiv (ITFixed IT16)) False PTAny $ JsForeign "%0 / %1"
, item (LUDiv (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) / (%1>>>0) |0"
@ -107,7 +107,7 @@ primDB =
, item (LSHL (ITFixed IT16)) False PTAny $ JsForeign "%0 << %1 & 0xFFFF"
, item (LSHL (ITFixed IT32)) False PTAny $ JsForeign "%0 << %1 | 0"
, item (LSHL (ITFixed IT64)) True PTAny $
\[l, r] -> JsForeign "%0.shiftLeft(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
\[l, r] -> JsForeign "%0.shiftLeft(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
, item (LSHL ITBig) True PTAny $ method "shiftLeft"
, item (LLSHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
, item (LLSHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
@ -172,11 +172,11 @@ primDB =
, item (LSGe (ATInt (ITFixed IT16))) False PTBool $ binop ">="
, item (LSGe (ATInt (ITFixed IT32))) False PTBool $ binop ">="
, item (LSGe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
, item (LSExt ITNative ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(''+%0)"
, item (LSExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
, item (LZExt (ITFixed IT8) ITNative) False PTAny $ head
, item (LZExt (ITFixed IT16) ITNative) False PTAny $ head
, item (LZExt (ITFixed IT32) ITNative) False PTAny $ head
, item (LZExt ITNative ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(''+%0)"
, item (LZExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
, item (LTrunc ITBig ITNative) True PTAny $ JsForeign "%0.intValue()|0"
, item (LTrunc (ITFixed IT16) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
, item (LTrunc (ITFixed IT32) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
@ -185,7 +185,7 @@ primDB =
, item (LTrunc (ITFixed IT64) (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
, item (LTrunc (ITFixed IT64) (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
, item (LTrunc ITBig (ITFixed IT64)) True PTAny $
\[x] -> JsForeign "%0.and(new jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
\[x] -> JsForeign "%0.and(new $JSRTS.jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
, item LStrConcat False PTAny $ binop "+"
, item LStrLt False PTBool $ binop "<"
, item LStrEq False PTBool $ binop "=="
@ -196,7 +196,7 @@ primDB =
, item (LIntStr ITNative) False PTAny $ JsForeign "''+%0"
, item (LIntStr ITBig) True PTAny $ JsForeign "%0.toString()"
, item (LStrInt ITNative) False PTAny $ JsForeign "parseInt(%0)|0"
, item (LStrInt ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(%0)"
, item (LStrInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)"
, item (LFloatStr) False PTAny $ JsForeign "''+%0"
, item (LStrFloat) False PTAny $ jsAppN "parseFloat"
, item (LChInt ITNative) False PTAny $ JsForeign "%0.charCodeAt(0)|0"
@ -218,9 +218,11 @@ primDB =
, item LStrCons False PTAny $ JsForeign "%0+%1"
, item LStrIndex False PTAny $ \[x, y] -> JsArrayProj y x
, item LStrRev False PTAny $ JsForeign "%0.split('').reverse().join('')"
, item LStrSubstr False PTAny $ JsForeign "%0.slice(Math.max(0,%1), Math.max(0, %2))"
, item LSystemInfo False PTAny $ jsAppN "js_idris_systemInfo"
, item LStrSubstr False PTAny $ JsForeign "$JSRTS.prim_strSubstr(%0, %1, %2)"
, item LSystemInfo False PTAny $ JsApp (JsProp (JsVar "$JSRTS") "prim_systemInfo")
, item LCrash False PTAny $ \[l] -> JsErrorExp l
, item LReadStr False PTAny $ \[_] -> JsApp (JsProp (JsVar "$JSRTS") "prim_readStr") []
, item LWriteStr False PTAny $ \[_, str] -> JsApp (JsProp (JsVar "$JSRTS") "prim_writeStr") [str]
, item LNoOp False PTAny $ head
]
where