a254920 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

fixed tail call optim when closuser involved

commita2549201909fe743b927eadd0cafd36e544c9cf1 authorRui Barreiro <rui.barreiro@gmail.com> dateTue 25 Apr 2017, 19:08 (9 years ago) parentdc44b02

3 files changed+150−58

compare with master

unifiedsplit

src/IRTS/CodegenJavaScript.hs+32−6 src/IRTS/JavaScript/AST.hs+24−13 src/IRTS/JavaScript/Codegen.hs+94−39

src/IRTS/CodegenJavaScript.hs+32−6

@@ -14,24 +14,50 @@ module IRTS.CodegenJavaScript (codegenJavaScript

1414import IRTS.CodegenCommon

1515import IRTS.JavaScript.Codegen

1616import System.Directory

17+import System.FilePath

18+import Data.Char

19+import Data.Text (Text)

20+import qualified Data.Text as T

1721

1822

1923data JSTarget = Node | JavaScript deriving Eq

2024

2125

26+htmlHeader :: Text

27+htmlHeader =

28+ T.concat [ "<html>\n"

29+ , " <head>\n"

30+ , " <meta charset='utf-8'>\n"

31+ , " </head>\n"

32+ , " <body>\n"

33+ , " <script type='text/javascript'>\n"

34+ ]

35+

36+htmlFooter :: Text

37+htmlFooter =

38+ T.concat [ "\n </script>\n"

39+ , " </body>\n"

40+ , "</html>"

41+ ]

42+

2243codegenJavaScript :: CodeGenerator

2344codegenJavaScript ci =

24− codegenJs (CGConf { header = ""

25− , initialization = const ""

26− , writeStrTemplate = "console.log(%0)"

27− }

28− )

29− ci

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

46+ (htmlHeader, htmlFooter)

47+ else ("","")

48+ in codegenJs (CGConf { header = h

49+ , footer = f

50+ , initialization = const ""

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

52+ }

53+ )

54+ ci

3055

3156codegenNode :: CodeGenerator

3257codegenNode ci =

3358 do

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

60+ , footer = ""

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

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

3763 }

src/IRTS/JavaScript/AST.hs+24−13

@@ -19,15 +19,18 @@ import Data.Data

1919data JsAST = JsEmpty

2020 | JsNull

2121 | JsLambda [Text] JsAST

22+ | JsCurryLambda [Text] JsAST

2223 | JsFun Text [Text] JsAST

23− | JsCurryFun Text [Text] JsAST

24+-- | JsCurryFun Text [Text] JsAST

2425 | JsReturn JsAST

2526 | JsApp Text [JsAST]

2627 | JsCurryApp JsAST [JsAST]

2728 | JsMethod JsAST Text [JsAST]

2829 | JsVar Text

2930 | JsSeq JsAST JsAST

30− | JsDecVar Text JsAST

31+ | JsConst Text JsAST

32+ | JsLet Text JsAST

33+ | JsLetList [(Text, JsAST)]

3134 | JsSetVar Text JsAST

3235 | JsArrayProj JsAST JsAST

3336 | JsInt Int

@@ -41,9 +44,11 @@ data JsAST = JsEmpty

4144 | JsBinOp Text JsAST JsAST

4245 | JsForeign Text [JsAST]

4346 | JsB2I JsAST

44− | JsWhileTrue JsAST

47+ -- | JsWhileTrue JsAST

48+ | JsFor (JsAST, JsAST, JsAST) JsAST

4549 | JsContinue

4650 | JsBreak

51+ | JsTrue

4752 | JsComment Text

4853 | JsForce JsAST

4954 | JsLazy JsAST

@@ -60,9 +65,9 @@ curryDef :: [Text] -> JsAST -> Text

6065curryDef [] body =

6166 jsAst2Text body

6267curryDef (x:xs) body =

63− T.concat [ "return function", "(", x, "){\n"

64− , indent $ curryDef xs body

65− , "}\n"

68+ T.concat [ "(function", "(", x, "){return "

69+ , curryDef xs body

70+ , "})"

6671 ]

6772

6873

@@ -74,18 +79,20 @@ jsAst2Text (JsLambda args body) =

7479 , jsAst2Text body

7580 , "})"

7681 ]

82+jsAst2Text (JsCurryLambda args body) = curryDef args body

7783jsAst2Text (JsFun name args body) =

78− T.concat [ "function ", name, "(", T.intercalate ", " args , "){\n"

84+ T.concat [ "var ", name, " = function(", T.intercalate ", " args , "){\n"

7985 , indent $ jsAst2Text body

8086 , "}\n"

8187 ]

82−jsAst2Text (JsCurryFun name args body) =

88+{-jsAst2Text (JsCurryFun name args body) =

8389 T.concat [ "var ", name, " = \n"

8490 , indent $ T.concat [ "(function(){\n"

8591 , indent $ curryDef args body

8692 , "})()"

8793 ]

8894 ]

95+-}

8996jsAst2Text (JsReturn x) = T.concat [ "return ", jsAst2Text x]

9097jsAst2Text (JsApp fn args) = T.concat [fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]

9198jsAst2Text (JsCurryApp fn []) = jsAst2Text fn

@@ -101,7 +108,9 @@ jsAst2Text (JsVar x) = x

101108jsAst2Text (JsSeq JsEmpty y) = jsAst2Text y

102109jsAst2Text (JsSeq x JsEmpty) = jsAst2Text x

103110jsAst2Text (JsSeq x y) = T.concat [jsAst2Text x, ";\n", jsAst2Text y]

104−jsAst2Text (JsDecVar name exp) = T.concat [ "var ", name, " = ", jsAst2Text exp]

111+jsAst2Text (JsConst name exp) = T.concat [ "const ", name, " = ", jsAst2Text exp]

112+jsAst2Text (JsLet name exp) = T.concat [ "let ", name, " = ", jsAst2Text exp]

113+jsAst2Text (JsLetList lst) = T.concat [ "let ", T.intercalate ", " (map (\(n,v) -> T.concat [n, " = ", jsAst2Text v] ) lst) ]

105114jsAst2Text (JsSetVar name exp) = T.concat [ name, " = ", jsAst2Text exp]

106115jsAst2Text (JsArrayProj i exp) = T.concat [ jsAst2Text exp, "[", jsAst2Text i, "]"]

107116jsAst2Text (JsInt i) = T.pack $ show i

@@ -126,15 +135,17 @@ jsAst2Text (JsForeign code args) =

126135 args_repl c i (t:r) = args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i+1) r

127136 in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]

128137jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)

129−jsAst2Text (JsWhileTrue x) =

130− T.concat [ "while(true){\n"

131− , indent $ jsAst2Text x

138+jsAst2Text (JsFor (x,y,z) w) =

139+ T.concat [ "for(", jsAst2Text x , "; ",jsAst2Text y, "; ",jsAst2Text z,"){\n"

140+ , indent $ jsAst2Text w

132141 , "}\n"

133142 ]

134143jsAst2Text JsContinue =

135144 "continue"

136145jsAst2Text JsBreak =

137146 "break"

147+jsAst2Text JsTrue =

148+ "true"

138149jsAst2Text (JsComment c)=

139150 T.concat ["/*",c,"*/"]

140151jsAst2Text (JsLazy e) =

@@ -159,7 +170,7 @@ throw2 = T.concat [ "var js_idris_throw2 = function (x){\n"

159170 ]

160171

161172force = T.concat [ "var js_idris_force = function (x){\n"

162− , " if(x.js_idris_lazy_calc === undefined){\n"

173+ , " if(x === undefined || x.js_idris_lazy_calc === undefined){\n"

163174 , " return x\n"

164175 , " }else{\n"

165176 , " if(x.js_idris_lazy_val === undefined){\n"

src/IRTS/JavaScript/Codegen.hs+94−39

@@ -48,6 +48,7 @@ emptyStats :: CGStats

4848emptyStats = CGStats {usedWriteStr = False}

4949

5050data CGConf = CGConf { header :: Text

51+ , footer :: Text

5152 , initialization :: CGStats -> Text

5253 , writeStrTemplate :: Text

5354 }

@@ -81,7 +82,7 @@ codegenJs conf ci =

8182 used `deepseq` if debug then

8283 do

8384 putStrLn $ "Finished calculating used"

84− writeFile (outputFile ci ++ ".LDecls") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"

85+ writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"

8586 else pure ()

8687

8788 let (out, stats) = doCodegen conf defs used --T.intercalate "\n" $ map (doCodegen conf defs) used

@@ -94,8 +95,10 @@ codegenJs conf ci =

9495 , includes, "\n"

9596 , js_aux_defs, "\n"

9697 , out, "\n"

97− , "\n\n"

98+ , "\n"

99+ , jsName (sMN 0 "runMain"), "();\n\n"

98100 , "\n}())"

101+ , footer conf

99102 ]

100103

101104jsName :: Name -> Text

@@ -136,20 +139,43 @@ getNewCGName =

136139 put $ st {lastIntName = v}

137140 return $ T.pack $ "cgIdris_" ++ show v

138141

142+getNewCGNames :: Int -> State CGBodyState [Text]

143+getNewCGNames n =

144+ mapM (\_ -> getNewCGName) [1..n]

145+

139146getConsId :: Name -> State CGBodyState Int

140147getConsId n =

141148 do

142149 st <- get

143150 case lookupCtxtExact n (defs st) of

144151 Just (LConstructor _ conId _) -> pure conId

145− _ -> error $ "ups " ++ showCG n

152+ _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."

146153

154+getArgList :: Name -> State CGBodyState (Maybe [Name])

155+getArgList n =

156+ do

157+ st <- get

158+ case lookupCtxtExact n (defs st) of

159+ Just (LFun _ _ a _) -> pure $ Just a

160+ _ -> pure Nothing

147161

148162data BodyResTarget = ReturnBT

149− | DecVarBT Text

150− | SetVarBT Text

163+ | DecBT Text

164+ | SetBT Text

165+ | DecConstBT Text

151166 | GetExpBT

152167

168+replaceVarsByProj :: JsAST -> Map Text Int -> JsAST -> JsAST

169+replaceVarsByProj n d z =

170+ transform f z

171+ where

172+ f :: JsAST -> JsAST

173+ f (JsVar x) =

174+ case Map.lookup x d of

175+ Nothing -> (JsVar x)

176+ Just i -> JsArrayProj (JsInt i) n

177+ f x = x

178+

153179cgFun :: CGConf -> LDefs -> Name -> [Name] -> LExp -> (JsAST, CGStats)

154180cgFun cnf dfs n args def =

155181 let

@@ -165,9 +191,15 @@ cgFun cnf dfs n args def =

165191 , usedWrite = False

166192 }

167193 )

168− body = if isTailRec st then JsWhileTrue $ (seqJs decs) `JsSeq` res `JsSeq` JsBreak

194+ body = if isTailRec st then

195+ JsFor (JsLetList [("cgArgs", JsApp "Array.prototype.slice.call" [JsVar "arguments"]), ("cgArgs2", JsNull) ] , JsTrue, JsSetVar "cgArgs" (JsVar "cgArgs2") ) $

196+ --JsSeq (JsDecVar "cgArgs" $ JsApp "Array.prototype.slice.call" [JsVar "arguments"]) $ JsWhileTrue $

197+ replaceVarsByProj

198+ (JsVar "cgArgs")

199+ (Map.fromList $ zip argNames [0..])

200+ ((seqJs decs) `JsSeq` res)

169201 else JsSeq (seqJs decs) res

170− in (JsCurryFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st})

202+ in (JsFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st})

171203

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

173205getSwitchJs x alts =

@@ -178,30 +210,61 @@ getSwitchJs x alts =

178210

179211addRT :: BodyResTarget -> JsAST -> JsAST

180212addRT ReturnBT x = JsReturn x

181−addRT (DecVarBT n) x = JsDecVar n x

182−addRT (SetVarBT n) x = JsSetVar n x

213+addRT (DecBT n) x = JsLet n x

214+addRT (SetBT n) x = JsSetVar n x

215+addRT (DecConstBT n) x = JsConst n x

183216addRT GetExpBT x = x

184217

185218cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsAST], JsAST)

186219cgBody rt (LV (Glob n)) =

187− pure $ ([], addRT rt $ JsVar $ jsName n)

188−cgBody rt (LApp _ (LV (Glob fn)) args) =

220+ do

221+ argsFn <- getArgList n

222+ case argsFn of

223+ Just [] ->

224+ pure $ ([], addRT rt $ JsApp (jsName n) [])

225+ Just a ->

226+ do

227+ newNames <- getNewCGNames $ length a

228+ pure ([], addRT rt $ JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))

229+ Nothing ->

230+ pure $ ([], addRT rt $ JsVar $ jsName n)

231+cgBody rt (LApp tailcall (LV (Glob fn)) args) =

189232 do

190233 let fname = jsName fn

191234 st <- get

192235 let (currFn, argN) = currentFnNameAndArgs st

193236 z <- mapM (cgBody GetExpBT) args

237+ let argVals = map snd z

194238 let preDecs = concat $ map fst z

195− case (fname == currFn, rt) of

239+ case (fname == currFn && (length args) == (length argN), rt) of

196240 (True, ReturnBT) ->

197241 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)

242+ modify (\x-> x {isTailRec = True})

243+ --vars <- getNewCGNames $ length argN --sequence $ map (\_->getNewCGName) argN

244+ let refreshArgs = JsSetVar "cgArgs2" (JsArray argVals)

245+ --let calcs = map (\(n,v) -> JsDecVar n v) (zip vars argVals)

246+ --let calcsToArgs = map (\(n,v) -> JsSetVar n (JsVar v)) (zip argN vars)

247+ pure (preDecs, refreshArgs)

203248 _ ->

204− pure $ (preDecs, addRT rt $ JsCurryApp (JsVar fname) (map snd z))

249+ do

250+ argsFn <- getArgList fn

251+ case argsFn of

252+ Nothing ->

253+ pure (preDecs, addRT rt $ JsCurryApp (JsVar fname) argVals )

254+ Just agFn ->

255+ do

256+ let lenAgFn = length agFn

257+ let lenArgs = length args

258+ case compare lenAgFn lenArgs of

259+ EQ ->

260+ pure (preDecs, addRT rt $ JsApp fname argVals)

261+ LT ->

262+ pure (preDecs, addRT rt $ JsCurryApp (JsApp fname (take lenAgFn argVals )) (drop lenAgFn argVals) )

263+ GT ->

264+ do

265+ newNames <- getNewCGNames $ lenAgFn - lenArgs

266+ pure (preDecs, addRT rt $ JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )

267+

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

206269cgBody rt (LLazyApp n args) =

207270 do

@@ -213,7 +276,7 @@ cgBody rt (LForce e) =

213276 pure (d, addRT rt $ JsForce v)

214277cgBody rt (LLet n v sc) =

215278 do

216− (d1, v1) <- cgBody (DecVarBT $ jsName n) v

279+ (d1, v1) <- cgBody (DecConstBT $ jsName n) v

217280 (d2, v2) <- cgBody rt sc

218281 pure $ ((d1 ++ v1 : d2), v2 )

219282cgBody rt (LProj e i) =

@@ -230,17 +293,19 @@ cgBody rt (LCase _ e alts) =

230293 resName <- getNewCGName

231294 swName <- getNewCGName

232295 (altsJs,def) <- cgAlts rt resName (JsVar swName) alts

233− let decSw = JsDecVar swName v

296+ let decSw = JsConst swName v

234297 let sw = JsSwitchCase (getSwitchJs (JsVar swName) alts) altsJs def

235298 case rt of

236299 ReturnBT ->

237300 pure (d ++ [decSw], sw)

238− (DecVarBT nvar) ->

239− pure (d ++ [decSw, JsDecVar nvar JsNull], sw)

240− (SetVarBT nvar) ->

301+ (DecBT nvar) ->

302+ pure (d ++ [decSw, JsLet nvar JsNull], sw)

303+ (SetBT nvar) ->

241304 pure (d ++ [decSw], sw)

242305 GetExpBT ->

243− pure (d ++ [decSw, JsDecVar resName JsNull, sw], JsVar resName)

306+ pure (d ++ [decSw, JsLet resName JsNull, sw], JsVar resName)

307+ (DecConstBT nvar) ->

308+ pure (d ++ [decSw, JsLet nvar JsNull], sw)

244309cgBody rt (LConst c) = pure ([], (addRT rt) $ cgConst c)

245310cgBody rt (LOp op args) =

246311 do

@@ -256,22 +321,12 @@ cgBody rt x@(LForeign dres (FStr code) args ) =

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

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

258323

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−

270324altsRT :: Text -> BodyResTarget -> BodyResTarget

271325altsRT rn ReturnBT = ReturnBT

272−altsRT rn (DecVarBT n) = SetVarBT n

273−altsRT rn (SetVarBT n) = SetVarBT n

274−altsRT rn GetExpBT = SetVarBT rn

326+altsRT rn (DecBT n) = SetBT n

327+altsRT rn (SetBT n) = SetBT n

328+altsRT rn (DecConstBT n) = SetBT n

329+altsRT rn GetExpBT = SetBT rn

275330

276331cgAlts :: BodyResTarget -> Text -> JsAST -> [LAlt] -> State CGBodyState ([(JsAST, JsAST)], Maybe JsAST)

277332cgAlts rt resName scrvar ((LConstCase t exp):r) =

@@ -289,7 +344,7 @@ cgAlts rt resName scrvar ((LConCase _ n args exp):r) =

289344 (ar, def) <- cgAlts rt resName scrvar r

290345 conId <- getConsId n

291346 -- let branchBody = JsSeq (conCaseToProjs 1 scrvar args) $ JsSeq (seqJs d) v

292− let replace = replaceMatchVars scrvar (Map.fromList $ zip (map jsName args) [1..])

347+ let replace = replaceVarsByProj scrvar (Map.fromList $ zip (map jsName args) [1..])

293348 let branchBody = JsSeq (seqJs $ map replace d) (replace v)

294349 pure ((JsInt conId, branchBody) : ar, def)

295350cgAlts _ _ _ [] =