c2df755 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

JS Codegen : Add call specialize

c2df755be5invis9 years ago

src/IRTS/JavaScript/Codegen.hs+36−36

compare with master

unifiedsplit

@@ -80,12 +80,7 @@ isYes _ = False

80codegenJs :: CGConf -> CodeGenerator

81codegenJs conf ci =

82 do

83− optim <- isYes <$> lookupEnv "IDRISJS_OPTIM"

84 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"

83 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"

85− if debug then

86− if optim then putStrLn "compiling width idris-js optimizations"

87− else putStrLn "compiling widthout idris-js optimizations"

88− else pure ()

89 let defs = Map.fromList $ liftDecls ci

84 let defs = Map.fromList $ liftDecls ci

90 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]

85 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]

91 if debug then

86 if debug then

@@ -108,12 +103,15 @@ codegenJs conf ci =

108 TIO.writeFile (outputFile ci) $ T.concat [ header conf

103 TIO.writeFile (outputFile ci) $ T.concat [ header conf

109 , "\"use strict\";\n\n"

104 , "\"use strict\";\n\n"

110 , "(function(){\n\n"

105 , "(function(){\n\n"

106+ -- rts

111 , runtimeCommon, "\n"

107 , runtimeCommon, "\n"

112 , extraRT, "\n"

108 , extraRT, "\n"

113 , jsbn, "\n"

109 , jsbn, "\n"

110+ -- external libraries

111+ , includes, "\n"

112+ -- user code

114 , doPartials (partialApplications stats), "\n"

113 , doPartials (partialApplications stats), "\n"

115 , doHiddenClasses (hiddenClasses stats), "\n"

114 , doHiddenClasses (hiddenClasses stats), "\n"

116− , includes, "\n"

117 , out, "\n"

115 , out, "\n"

118 , jsName (sMN 0 "runMain"), "();\n"

116 , jsName (sMN 0 "runMain"), "();\n"

119 , "}.call(this))"

117 , "}.call(this))"

@@ -135,6 +133,7 @@ doHiddenClasses :: Set HiddenClass -> Text

135doHiddenClasses x =

133doHiddenClasses x =

136 T.intercalate "\n" (map f $ Set.toList x)

134 T.intercalate "\n" (map f $ Set.toList x)

137 where

135 where

136+ f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]

138 f p@(HiddenClass n id arity) =

137 f p@(HiddenClass n id arity) =

139 let vars = map dataPartName $ take arity [1..]

138 let vars = map dataPartName $ take arity [1..]

140 in jsStmt2Text $

139 in jsStmt2Text $

@@ -349,27 +348,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =

349 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty

348 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty

350 addUsedArgsTailCallOptim y3

349 addUsedArgsTailCallOptim y3

351 pure (preDecs, y1 `JsSeq` y2)

350 pure (preDecs, y1 `JsSeq` y2)

352− _ ->

351+ _ -> do

353− do

352+ app <- formApp fn argVals

354− argsFn <- getArgList fn

355− case argsFn of

356− Nothing -> do

357− fn' <- cgName fn

358− pure (preDecs, addRT rt $ jsCurryApp fn' argVals )

359− Just agFn ->

360− do

361− let lenAgFn = length agFn

362− let lenArgs = length args

363− case compare lenAgFn lenArgs of

364− EQ ->

365− pure (preDecs, addRT rt $ jsAppN fname argVals)

353+ pure (preDecs, addRT rt app)

366− LT ->

367− pure (preDecs, addRT rt $ jsCurryApp (jsAppN fname (take lenAgFn argVals)) (drop lenAgFn argVals) )

368− GT ->

369− do

370− let part = Partial fn lenArgs lenAgFn

371− addPartial part

372− pure (preDecs, addRT rt $ jsAppN (jsNamePartial part) argVals )

373

354

374cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)

355cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)

375cgBody' rt (LLazyApp n args) =

356cgBody' rt (LLazyApp n args) =

@@ -447,18 +428,36 @@ altHasNoProj :: LAlt -> Bool

447altHasNoProj (LConCase _ _ args _) = args == []

428altHasNoProj (LConCase _ _ args _) = args == []

448altHasNoProj _ = True

429altHasNoProj _ = True

449

430

431+formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr

432+formApp fn argVals = case specialCall fn of

433+ Just (arity, g) | arity == length argVals -> pure $ g argVals

434+ _ -> do

435+ argsFn <- getArgList fn

436+ fname <- cgName fn

437+ case argsFn of

438+ Nothing -> pure $ jsCurryApp fname argVals

439+ Just agFn -> do

440+ let lenAgFn = length agFn

441+ let lenArgs = length argVals

442+ case compare lenAgFn lenArgs of

443+ EQ -> pure $ JsApp fname argVals

444+ LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)

445+ GT -> do

446+ let part = Partial fn lenArgs lenAgFn

447+ addPartial part

448+ pure $ jsAppN (jsNamePartial part) argVals

449+

450formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr

451formCon n args = do

452 case specialCased n of

453 Just (ctor, test, match) -> pure $ ctor args

454 Nothing -> do

455 (conId, arity) <- getConsId n

456− if (arity > 0)

457− then do

458− let hc = HiddenClass n conId arity

456+ let hc = HiddenClass n conId arity

459− addHiddenClass hc

457+ addHiddenClass hc

458+ pure $ if (arity > 0)

460− pure $ JsNew (JsVar $ jsNameHiddenClass hc) args

459+ then JsNew (JsVar $ jsNameHiddenClass hc) args

461− else pure $ JsInt conId

460+ else JsVar $ jsNameHiddenClass hc

462

461

463formConTest :: Name -> JsExpr -> State CGBodyState JsExpr

462formConTest :: Name -> JsExpr -> State CGBodyState JsExpr

464formConTest n x = do

463formConTest n x = do

@@ -466,9 +465,10 @@ formConTest n x = do

466 Just (ctor, test, match) -> pure $ test x

465 Just (ctor, test, match) -> pure $ test x

467 Nothing -> do

466 Nothing -> do

468 (conId, arity) <- getConsId n

467 (conId, arity) <- getConsId n

468+ pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)

469− if (arity > 0)

469+ -- if (arity > 0)

470− then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)

470+ -- then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)

471− else pure $ JsBinOp "===" x (JsInt conId)

471+ -- else pure $ JsBinOp "===" x (JsInt conId)

472

473formProj :: Name -> JsExpr -> Int -> JsExpr

474formProj n v i =

src/IRTS/JavaScript/PrimOp.hs+5−5

@@ -37,7 +37,7 @@ primDB =

37 Map.fromList [

38 item (LPlus ATFloat) False PTAny $ binop "+"

39 , item (LPlus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))"

40− , item (LPlus (ATInt ITNative)) False PTAny $ JsForeign "%0+%1|0"

40+ , item (LPlus (ATInt ITNative)) False PTAny $ binop "+"

41 , item (LPlus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 + %1 & 0xFF"

42 , item (LPlus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 + %1 & 0xFFFF"

43 , item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"

@@ -46,7 +46,7 @@ primDB =

46 \[l, r] -> JsForeign "%0.add(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]

47 , item (LMinus ATFloat) False PTAny $ binop "-"

48 , item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"

49− , item (LMinus (ATInt ITNative)) False PTAny $ JsForeign "%0-%1|0"

49+ , item (LMinus (ATInt ITNative)) False PTAny $ binop "-"

50 , item (LMinus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 - %1 & 0xFF"

51 , item (LMinus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 - %1 & 0xFFFF"

52 , item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"

@@ -55,7 +55,7 @@ primDB =

55 \[l, r] -> JsForeign "%0.subtract(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]

56 , item (LTimes ATFloat) False PTAny $ binop "*"

57 , item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"

58− , item (LTimes (ATInt ITNative)) False PTAny $ JsForeign "%0*%1|0"

58+ , item (LTimes (ATInt ITNative)) False PTAny $ binop "*"

59 , item (LTimes (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 * %1 & 0xFF"

60 , item (LTimes (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 * %1 & 0xFFFF"

61 , item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"

@@ -71,14 +71,14 @@ primDB =

71 , item (LSDiv (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 / %1"

72 , item (LSDiv (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 / %1 |0"

73 , item (LSDiv (ATInt (ITFixed IT64))) True PTAny $ JsForeign "%0.divide(%1)"

74− , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0"

74+ , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0" -- we need "|0" in this

75 , item (LSDiv (ATInt ITBig)) True PTAny $ method "divide"

76 , item (LURem (ITFixed IT8)) False PTAny $ JsForeign "%0 % %1"

77 , item (LURem (ITFixed IT16)) False PTAny $ JsForeign "%0 % %1"

78 , item (LURem (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) % (%1>>>0) |0"

79 , item (LURem (ITFixed IT64)) True PTAny $ method "remainder"

80 , item (LSRem ATFloat) False PTAny $ binop "%"

81− , item (LSRem (ATInt ITNative)) False PTAny $ JsForeign "%0 % %1 |0"

81+ , item (LSRem (ATInt ITNative)) False PTAny $ binop "%"

82 , item (LSRem (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 % %1"

83 , item (LSRem (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 % %1"

84 , item (LSRem (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 % %1 |0"