da46fd6 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

added function name to error message for invalid ffi types

da46fd6Rui Barreiro9 years ago

src/IRTS/CodegenJavaScript.hs+32−1

compare with master

unifiedsplit

@@ -40,6 +40,29 @@ htmlFooter =

40 , "</html>"

41 ]

43+nodeReadLine :: Text

44+nodeReadLine =

45+ T.concat [ "var js_idris_readStr = function() {\n"

46+ , " var ret = '';"

47+ , " var b = new Buffer(1024);"

48+ , " var i = 0;\n"

49+ , " while(true) {\n"

50+ , " fs.readSync(0, b, i, 1 )\n"

51+ , " if (b[i] == 10) {\n"

52+ , " ret = b.toString('utf8', 0, i);\n"

53+ , " break;\n"

54+ , " }\n"

55+ , " i++;\n"

56+ , " if (i == b.length) {\n"

57+ , " nb = new Buffer (b.length*2);\n"

58+ , " b.copy(nb)\n"

59+ , " b = nb;\n"

60+ , " }\n"

61+ , " }\n"

62+ , " return ret;\n"

63+ , " };\n"

64+ ]

65+

43codegenJavaScript :: CodeGenerator

66codegenJavaScript :: CodeGenerator

44codegenJavaScript ci =

67codegenJavaScript ci =

45 let (h, f) = if (map toLower $ takeExtension $ outputFile ci) == ".html" then

68 let (h, f) = if (map toLower $ takeExtension $ outputFile ci) == ".html" then

@@ -49,17 +72,25 @@ codegenJavaScript ci =

49 , footer = f

72 , footer = f

50 , initialization = const ""

73 , initialization = const ""

51 , writeStrTemplate = "console.log(%0)"

74 , writeStrTemplate = "console.log(%0)"

75+ , readStrTemplate = "prompt('Prelude.getLine')"

52 }

76 }

53 )

77 )

54 ci

78 ci

80+initializationNode :: CGStats -> Text

81+initializationNode x =

82+ T.concat [ if usedWriteStr x || usedReadStr x then "var fs = require('fs');\n" else ""

83+ , if usedReadStr x then nodeReadLine else ""

84+ ]

85+

56codegenNode :: CodeGenerator

86codegenNode :: CodeGenerator

57codegenNode ci =

87codegenNode ci =

58 do

88 do

59 codegenJs (CGConf { header = "#!/usr/bin/env node\n"

89 codegenJs (CGConf { header = "#!/usr/bin/env node\n"

60 , footer = ""

90 , footer = ""

61− , initialization = \x -> if usedWriteStr x then "var fs = require('fs');\n" else ""

91+ , initialization = initializationNode

62 , writeStrTemplate = "fs.writeSync(1,%0)"

92 , writeStrTemplate = "fs.writeSync(1,%0)"

93+ , readStrTemplate = "js_idris_readStr()"

63 }

94 }

64 )

95 )

65 ci

96 ci

src/IRTS/JavaScript/Codegen.hs+86−28

@@ -44,17 +44,19 @@ import Data.Char

44data Partial = Partial Name Int Int deriving (Eq, Ord)

46data CGStats = CGStats { usedWriteStr :: Bool

47+ , usedReadStr :: Bool

47 , usedBigInt :: Bool

48 , usedBigInt :: Bool

48 , partialApplications :: Set Partial

49 , partialApplications :: Set Partial

49 }

50 }

51emptyStats :: CGStats

52emptyStats :: CGStats

52−emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty, usedBigInt = False}

53+emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty, usedBigInt = False, usedReadStr = False}

54data CGConf = CGConf { header :: Text

55data CGConf = CGConf { header :: Text

55 , footer :: Text

56 , footer :: Text

56 , initialization :: CGStats -> Text

57 , initialization :: CGStats -> Text

57 , writeStrTemplate :: Text

58 , writeStrTemplate :: Text

59+ , readStrTemplate :: Text

58 }

60 }

@@ -141,6 +143,7 @@ doCodegen conf defs decls =

141 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y

143 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y

142 , partialApplications = partialApplications x `Set.union` partialApplications y

144 , partialApplications = partialApplications x `Set.union` partialApplications y

143 , usedBigInt = usedBigInt x || usedBigInt y

145 , usedBigInt = usedBigInt x || usedBigInt y

146+ , usedReadStr = usedReadStr x || usedReadStr y

144 }

147 }

145 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )

148 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )

146

149

@@ -163,6 +166,7 @@ data CGBodyState = CGBodyState { defs :: LDefs

163 , isTailRec :: Bool

166 , isTailRec :: Bool

164 , conf :: CGConf

167 , conf :: CGConf

165 , usedWrite :: Bool

168 , usedWrite :: Bool

169+ , usedRead :: Bool

166 , usedITBig :: Bool

170 , usedITBig :: Bool

167 , partialApps :: Set Partial

171 , partialApps :: Set Partial

168 }

172 }

@@ -234,6 +238,7 @@ cgFun cnf dfs n args def =

234 , isTailRec = False

238 , isTailRec = False

235 , conf = cnf

239 , conf = cnf

236 , usedWrite = False

240 , usedWrite = False

241+ , usedRead = False

237 , usedITBig = False

242 , usedITBig = False

238 , partialApps = Set.empty

243 , partialApps = Set.empty

239 }

244 }

@@ -243,7 +248,12 @@ cgFun cnf dfs n args def =

243 (declareUsedOptimArgs $ usedArgsTailCallOptim st)

248 (declareUsedOptimArgs $ usedArgsTailCallOptim st)

244 (JsWhileTrue ((seqJs decs) `JsSeq` res))

249 (JsWhileTrue ((seqJs decs) `JsSeq` res))

245 else (seqJs decs) `JsSeq` res

250 else (seqJs decs) `JsSeq` res

246− in (JsFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st, partialApplications = partialApps st, usedBigInt = usedITBig st})

251+ in (JsFun fnName argNames $ body, CGStats { usedWriteStr = usedWrite st

252+ , partialApplications = partialApps st

253+ , usedBigInt = usedITBig st

254+ , usedReadStr = usedRead st

255+ }

256+ )

247

257

248getSwitchJs :: JsAST -> [LAlt] -> JsAST

258getSwitchJs :: JsAST -> [LAlt] -> JsAST

249getSwitchJs x alts =

259getSwitchJs x alts =

@@ -387,8 +397,9 @@ cgBody rt (LError x) = pure ([JsError $ JsStr x], addRT rt JsNull)

387cgBody rt x@(LForeign dres (FStr code) args ) =

397cgBody rt x@(LForeign dres (FStr code) args ) =

388 do

398 do

389 z <- mapM (cgBody GetExpBT) (map snd args)

399 z <- mapM (cgBody GetExpBT) (map snd args)

390− let jsArgs = map cgForeignArg (zip (map fst args) (map snd z))

400+ jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map snd z))

391− pure $ (concat $ map fst z, addRT rt $ cgForeignRes dres $ JsForeign (T.pack code) jsArgs)

401+ jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs

402+ pure $ (concat $ map fst z, addRT rt $ jsDres)

392cgBody _ x = error $ "Instruction " ++ show x ++ " not compilable yet"

403cgBody _ x = error $ "Instruction " ++ show x ++ " not compilable yet"

393

404

394altsRT :: Text -> BodyResTarget -> BodyResTarget

405altsRT :: Text -> BodyResTarget -> BodyResTarget

@@ -428,24 +439,34 @@ cgAlts _ _ _ [] =

428 pure ([],Nothing)

439 pure ([],Nothing)

429

440

430

441

431−cgForeignArg :: (FDesc, JsAST) -> JsAST

442+cgForeignArg :: (FDesc, JsAST) -> State CGBodyState JsAST

432−cgForeignArg (FApp (UN "JS_IntT") _, v) = v

443+cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v

433−cgForeignArg (FCon (UN "JS_Str"), v) = v

444+cgForeignArg (FCon (UN "JS_Str"), v) = pure v

434−cgForeignArg (FCon (UN "JS_Ptr"), v) = v

445+cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v

435−cgForeignArg (FCon (UN "JS_Unit"), v) = v

446+cgForeignArg (FCon (UN "JS_Unit"), v) = pure v

436cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =

447cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =

437− f

448+ pure f

438cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =

449cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =

450+ do

451+ jsx <- cgForeignArg (a, JsVar "x")

439− JsLambda ["x"] $ JsReturn $ cgForeignRes b $ JsCurryApp (JsCurryApp f [cgForeignArg (a, JsVar "x")]) [JsNull]

452+ jsres <- cgForeignRes b $ JsCurryApp (JsCurryApp f [jsx]) [JsNull]

453+ pure $ JsLambda ["x"] $ JsReturn jsres

454+cgForeignArg (desc, _) =

455+ do

456+ st <- get

440−cgForeignArg (desc, _) = error $ "Foreign arg type " ++ show desc ++ " not supported yet."

457+ error $ "Foreign arg type " ++ show desc ++ " not supported yet. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

441−

458+

442−cgForeignRes :: FDesc -> JsAST -> JsAST

459+cgForeignRes :: FDesc -> JsAST -> State CGBodyState JsAST

443−cgForeignRes (FApp (UN "JS_IntT") _) x = x

460+cgForeignRes (FApp (UN "JS_IntT") _) x = pure x

444−cgForeignRes (FCon (UN "JS_Unit")) x = x

461+cgForeignRes (FCon (UN "JS_Unit")) x = pure x

445−cgForeignRes (FCon (UN "JS_Str")) x = x

462+cgForeignRes (FCon (UN "JS_Str")) x = pure x

446−cgForeignRes (FCon (UN "JS_Ptr")) x = x

463+cgForeignRes (FCon (UN "JS_Ptr")) x = pure x

447−cgForeignRes (FCon (UN "JS_Float")) x = x

464+cgForeignRes (FCon (UN "JS_Float")) x = pure x

465+--cgForeignRes _ x = x

466+cgForeignRes desc val =

467+ do

468+ st <- get

448−cgForeignRes desc val = error $ "Foreign return type " ++ show desc ++ " not supported yet."

469+ error $ "Foreign return type " ++ show desc ++ " not supported yet. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

449

470

450setUsedITBig :: State CGBodyState ()

471setUsedITBig :: State CGBodyState ()

451setUsedITBig = modify (\s -> s {usedITBig = True})

472setUsedITBig = modify (\s -> s {usedITBig = True})

@@ -484,6 +505,11 @@ cgOp (LMinus (ATInt ITBig)) [l, r] =

484 setUsedITBig

505 setUsedITBig

485 pure $ JsMethod l "subtract" [r]

506 pure $ JsMethod l "subtract" [r]

486cgOp (LTimes ATFloat) [l, r] = pure $ JsBinOp "*" l r

507cgOp (LTimes ATFloat) [l, r] = pure $ JsBinOp "*" l r

508+cgOp (LTimes (ATInt ITNative)) [l, r] = pure $ JsForeign "%0*%1|0" [l,r]

509+cgOp (LTimes (ATInt ITBig)) [l, r] =

510+ do

511+ setUsedITBig

512+ pure $ JsMethod l "multiply" [r]

487cgOp (LEq ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "==" l r

513cgOp (LEq ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "==" l r

488cgOp (LEq (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "==" l r

514cgOp (LEq (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "==" l r

489cgOp (LEq (ATInt ITChar)) [l,r] = pure $ jsB2I $ JsBinOp "==" l r

515cgOp (LEq (ATInt ITChar)) [l,r] = pure $ jsB2I $ JsBinOp "==" l r

@@ -493,44 +519,76 @@ cgOp (LEq (ATInt ITBig)) [l, r] =

493 pure $ jsB2I $ JsMethod l "equals" [r]

519 pure $ jsB2I $ JsMethod l "equals" [r]

494cgOp (LSLt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<" l r

520cgOp (LSLt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<" l r

495cgOp (LSLt (ATInt ITChar)) [l, r] = pure $ jsB2I $ JsBinOp "<" l r

521cgOp (LSLt (ATInt ITChar)) [l, r] = pure $ jsB2I $ JsBinOp "<" l r

522+cgOp (LSLt (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "<" l r

496cgOp (LSLt (ATInt ITBig)) [l, r] =

523cgOp (LSLt (ATInt ITBig)) [l, r] =

497 do

524 do

498 setUsedITBig

525 setUsedITBig

499 pure $ jsB2I $ JsForeign "%0.compareTo(%1) < 0" [l,r]

526 pure $ jsB2I $ JsForeign "%0.compareTo(%1) < 0" [l,r]

500cgOp (LSLe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r

527cgOp (LSLe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r

528+cgOp (LSLe (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r

529+cgOp (LSLe (ATInt ITBig)) [l, r] =

530+ do

531+ setUsedITBig

532+ pure $ jsB2I $ JsForeign "%0.compareTo(%1) <= 0" [l,r]

501cgOp (LSGt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">" l r

533cgOp (LSGt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">" l r

534+cgOp (LSGt (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp ">" l r

535+cgOp (LSGt (ATInt ITBig)) [l, r] =

536+ do

537+ setUsedITBig

538+ pure $ jsB2I $ JsForeign "%0.compareTo(%1) > 0" [l,r]

502cgOp (LSGe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r

539cgOp (LSGe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r

540+cgOp (LSGe (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r

541+cgOp (LSGe (ATInt ITBig)) [l, r] =

542+ do

543+ setUsedITBig

544+ pure $ jsB2I $ JsForeign "%0.compareTo(%1) >= 0" [l,r]

503cgOp LStrEq [l,r] = pure $ jsB2I $ JsBinOp "==" l r

545cgOp LStrEq [l,r] = pure $ jsB2I $ JsBinOp "==" l r

504cgOp LStrLen [x] = pure $ JsForeign "%0.length" [x]

546cgOp LStrLen [x] = pure $ JsForeign "%0.length" [x]

505cgOp LStrHead [x] = pure $ JsArrayProj (JsInt 0) x

547cgOp LStrHead [x] = pure $ JsArrayProj (JsInt 0) x

506cgOp LStrIndex [x, y] = pure $ JsArrayProj y x

548cgOp LStrIndex [x, y] = pure $ JsArrayProj y x

507cgOp LStrTail [x] = pure $ JsMethod x "slice" [JsInt 1]

549cgOp LStrTail [x] = pure $ JsMethod x "slice" [JsInt 1]

508cgOp LStrLt [l, r] = pure $ jsB2I $ JsBinOp "<" l r

550cgOp LStrLt [l, r] = pure $ jsB2I $ JsBinOp "<" l r

551+cgOp LStrRev [x] = pure $ JsForeign "%0.split('').reverse().join('')" [x]

509cgOp (LFloatStr) [x] = pure $ JsApp "String" [x]

552cgOp (LFloatStr) [x] = pure $ JsApp "String" [x]

510cgOp (LIntStr ITNative) [x] = pure $ JsApp "String" [x]

553cgOp (LIntStr ITNative) [x] = pure $ JsApp "String" [x]

511cgOp (LIntStr ITBig) [x] =

554cgOp (LIntStr ITBig) [x] =

512 do

555 do

513 setUsedITBig

556 setUsedITBig

514 pure $ JsForeign "%0.toString()" [x]

557 pure $ JsForeign "%0.toString()" [x]

515−--cgOp (LFloatInt _) [x] = pure $ JsApp "Math.trunc" [x]

558+cgOp (LFloatInt ITNative) [x] = pure $ JsForeign "%x|0" [x]

516−--cgOp (LStrInt _) [x] = pure $ JsBinOp "||" (JsApp "parseInt" [x]) (JsInt 0)

559+cgOp (LStrInt ITNative) [x] = pure $ JsForeign "parseInt(%0)|0" [x]

517cgOp (LStrFloat) [x] = pure $ JsApp "parseFloat" [x]

560cgOp (LStrFloat) [x] = pure $ JsApp "parseFloat" [x]

518−cgOp (LChInt _) [x] = pure $ JsForeign "%0.charCodeAt(0)|0" [x]

561+cgOp (LChInt ITNative) [x] = pure $ JsForeign "%0.charCodeAt(0)|0" [x]

519−--cgOp (LIntCh _) [x] = pure $ x

562+cgOp (LIntCh ITNative) [x] = pure $ JsApp "String.fromCharCode" [x]

563+cgOp (LTrunc ITBig ITNative) [x] = pure $ JsForeign "%0.intValue()|0" [x]

520cgOp (LSExt ITNative ITBig) [x] =

564cgOp (LSExt ITNative ITBig) [x] =

521 do

565 do

522 setUsedITBig

566 setUsedITBig

523 pure $ JsForeign "new jsbn.BigInteger(String(%0))" [x]

567 pure $ JsForeign "new jsbn.BigInteger(String(%0))" [x]

568+cgOp (LZExt ITNative ITBig) [x] =

569+ do

570+ setUsedITBig

571+ pure $ JsForeign "new jsbn.BigInteger(String(%0))" [x]

524--cgOp (LZExt _ _) [x] = pure $ x

572--cgOp (LZExt _ _) [x] = pure $ x

525−--cgOp (LIntFloat _) [x] = pure $ x

573+cgOp (LIntFloat ITNative) [x] = pure $ x

526−--cgOp (LSDiv _) [x,y] = pure $ JsBinOp "/" x y

574+cgOp (LSDiv (ATInt ITNative)) [l,r] = pure $ JsForeign "%0/%1|0" [l, r]

575+cgOp (LSDiv (ATInt ITBig)) [l,r] =

576+ do

577+ setUsedITBig

578+ pure $ JsMethod l "divide" [r]

527cgOp LWriteStr [_,str] =

579cgOp LWriteStr [_,str] =

528 do

580 do

529 s <- get

581 s <- get

530 put $ s {usedWrite = True}

582 put $ s {usedWrite = True}

531 pure $ JsForeign (writeStrTemplate $ conf s) [str]

583 pure $ JsForeign (writeStrTemplate $ conf s) [str]

584+cgOp LReadStr [_] =

585+ do

586+ s <- get

587+ put $ s {usedRead = True}

588+ pure $ JsForeign (readStrTemplate $ conf s) []

532cgOp LStrConcat [l,r] = pure $ JsBinOp "+" l r

589cgOp LStrConcat [l,r] = pure $ JsBinOp "+" l r

533−cgOp LStrCons [l,r] = pure $ JsForeign "%0+%1" [l,r] --JsForeign "String.fromCharCode(%0) + %1" [l,r]

590+cgOp LStrCons [l,r] = pure $ JsForeign "%0+%1" [l,r]

591+cgOp LStrSubstr [offset,len,str] = pure $ JsMethod str "substr" [offset, len]

534−--cgOp (LSRem (ATInt _)) [l,r] = pure $ JsBinOp "%" l r

592+cgOp (LSRem (ATInt ITNative)) [l,r] = pure $ JsBinOp "%" l r

535cgOp LCrash [l] = pure $ JsErrorExp l

593cgOp LCrash [l] = pure $ JsErrorExp l

536cgOp op exps = error ("Operator " ++ show (op, exps) ++ " not implemented")

594cgOp op exps = error ("Operator " ++ show (op, exps) ++ " not implemented")