da46fd6 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

added function name to error message for invalid ffi types

commitda46fd66ed1405c549f9a32d7f7c41f64ca53986 authorRui Barreiro <rui.barreiro@gmail.com> dateThu 4 May 2017, 09:21 (9 years ago) parent8453697

2 files changed+118−29

compare with master

unifiedsplit

src/IRTS/CodegenJavaScript.hs+32−1 src/IRTS/JavaScript/Codegen.hs+86−28

src/IRTS/CodegenJavaScript.hs+32−1

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

4040 , "</html>"

4141 ]

4242

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+

4366codegenJavaScript :: CodeGenerator

4467codegenJavaScript ci =

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

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

4972 , footer = f

5073 , initialization = const ""

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

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

5276 }

5377 )

5478 ci

5579

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+

5686codegenNode :: CodeGenerator

5787codegenNode ci =

5888 do

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

6090 , footer = ""

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

91+ , initialization = initializationNode

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

93+ , readStrTemplate = "js_idris_readStr()"

6394 }

6495 )

6596 ci

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

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

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

4545

4646data CGStats = CGStats { usedWriteStr :: Bool

47+ , usedReadStr :: Bool

4748 , usedBigInt :: Bool

4849 , partialApplications :: Set Partial

4950 }

5051

5152emptyStats :: CGStats

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

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

5354

5455data CGConf = CGConf { header :: Text

5556 , footer :: Text

5657 , initialization :: CGStats -> Text

5758 , writeStrTemplate :: Text

59+ , readStrTemplate :: Text

5860 }

5961

6062

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

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

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

143145 , usedBigInt = usedBigInt x || usedBigInt y

146+ , usedReadStr = usedReadStr x || usedReadStr y

144147 }

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

146149

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

163166 , isTailRec :: Bool

164167 , conf :: CGConf

165168 , usedWrite :: Bool

169+ , usedRead :: Bool

166170 , usedITBig :: Bool

167171 , partialApps :: Set Partial

168172 }

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

234238 , isTailRec = False

235239 , conf = cnf

236240 , usedWrite = False

241+ , usedRead = False

237242 , usedITBig = False

238243 , partialApps = Set.empty

239244 }

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

243248 (declareUsedOptimArgs $ usedArgsTailCallOptim st)

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

245250 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+ )

247257

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

249259getSwitchJs x alts =

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

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

388398 do

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

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

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

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

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

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

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

393404

394405altsRT :: Text -> BodyResTarget -> BodyResTarget

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

428439 pure ([],Nothing)

429440

430441

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

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

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

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

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

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

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

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

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

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

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

437− f

448+ pure f

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

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

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

441−

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

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

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

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

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

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

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

450+ do

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

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

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

454+cgForeignArg (desc, _) =

455+ do

456+ st <- get

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

458+

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

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

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

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

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

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

465+--cgForeignRes _ x = x

466+cgForeignRes desc val =

467+ do

468+ st <- get

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

449470

450471setUsedITBig :: State CGBodyState ()

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

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

484505 setUsedITBig

485506 pure $ JsMethod l "subtract" [r]

486507cgOp (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]

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

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

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

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

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

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

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

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

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

497524 do

498525 setUsedITBig

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

500527cgOp (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]

501533cgOp (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]

502539cgOp (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]

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

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

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

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

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

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

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

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

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

511554cgOp (LIntStr ITBig) [x] =

512555 do

513556 setUsedITBig

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

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

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

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

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

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

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

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

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

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

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

520564cgOp (LSExt ITNative ITBig) [x] =

521565 do

522566 setUsedITBig

523567 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]

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

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

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

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

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]

527579cgOp LWriteStr [_,str] =

528580 do

529581 s <- get

530582 put $ s {usedWrite = True}

531583 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) []

532589cgOp 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]

534−--cgOp (LSRem (ATInt _)) [l,r] = pure $ JsBinOp "%" 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]

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

535593cgOp LCrash [l] = pure $ JsErrorExp l

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