git.iko.soy/Idris-dev
on master help sign in
Merge pull request #3917 from geigerzaehler/refactor-js-codegen
80c84ccNiklas Larsson
CONTRIBUTORS+1
compare with master
unifiedsplit
@@ -200,6 +200,7 @@ Sven Koschnicke
200tdidriksen
200tdidriksen
201Tenor Biel
201Tenor Biel
202Thomas Cooper
202Thomas Cooper
203+Thomas Scholtes
203Tim Dysinger
204Tim Dysinger
204Tim McGilchrist
205Tim McGilchrist
205Timo Petteri Sinnemäki
206Timo Petteri Sinnemäki
src/IRTS/JavaScript/Codegen.hs+38−50
@@ -20,15 +20,16 @@ import IRTS.JavaScript.Name
20import IRTS.JavaScript.PrimOp
20import IRTS.JavaScript.PrimOp
21import IRTS.JavaScript.Specialize
21import IRTS.JavaScript.Specialize
22import IRTS.Lang
22import IRTS.Lang
23−import IRTS.LangOpts
24import IRTS.System
23import IRTS.System
25
24
25+import Control.Applicative (pure, (<$>))
26import Control.Monad
26import Control.Monad
27import Control.Monad.Trans.State
27import Control.Monad.Trans.State
28−import Data.List (nub)
28+import Data.Foldable (foldMap)
29+import Data.Generics.Uniplate.Data
30+import Data.List
29import Data.Map.Strict (Map)
31import Data.Map.Strict (Map)
30import qualified Data.Map.Strict as Map
32import qualified Data.Map.Strict as Map
31−import Data.Maybe (fromJust)
32import Data.Set (Set)
33import Data.Set (Set)
33import qualified Data.Set as Set
34import qualified Data.Set as Set
34import Data.Text (Text)
35import Data.Text (Text)
@@ -38,23 +39,27 @@ import System.Directory (doesFileExist)
38import System.Environment
39import System.Environment
39import System.FilePath
40import System.FilePath
40
41
41−import Control.Applicative (pure, (<$>))
42−import Data.Char
43−import Data.Data
44−import Data.Generics.Uniplate.Data
45−import Data.List
46−import GHC.Generics (Generic)
47
42
43+-- | Code generation stats hold information about the generated user
44+-- code. Based on that information we add additional code to make
45+-- things work.
48data CGStats = CGStats { usedBigInt :: Bool
46data CGStats = CGStats { usedBigInt :: Bool
49 , partialApplications :: Set Partial
47 , partialApplications :: Set Partial
50 , hiddenClasses :: Set HiddenClass
48 , hiddenClasses :: Set HiddenClass
51 }
49 }
52
50
53−emptyStats :: CGStats
51+-- If we generate code for two declarations we want to merge their code
52+-- generation stats.
53+instance Monoid CGStats where
54−emptyStats = CGStats { partialApplications = Set.empty
54+ mempty = CGStats { partialApplications = Set.empty
55− , hiddenClasses = Set.empty
55+ , hiddenClasses = Set.empty
56− , usedBigInt = False
56+ , usedBigInt = False
57− }
57+ }
58+ mappend x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
59+ , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
60+ , usedBigInt = usedBigInt x || usedBigInt y
61+ }
62+
58
63
59data CGConf = CGConf { header :: Text
64data CGConf = CGConf { header :: Text
60 , footer :: Text
65 , footer :: Text
@@ -101,13 +106,11 @@ codegenJs conf ci =
101 let defs' = Map.fromList $ liftDecls ci
106 let defs' = Map.fromList $ liftDecls ci
102 let defs = globlToCon defs'
107 let defs = globlToCon defs'
103 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
108 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
104− if debug then
109+ when debug $ do
105− do
106 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
110 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
107 putStrLn $ "Finished calculating used"
111 putStrLn $ "Finished calculating used"
108− else pure ()
109
112
110− let (out, stats) = doCodegen conf defs used
113+ let (out, stats) = doCodegen defs used
111
114
112 path <- getIdrisJSRTSDir
115 path <- getIdrisJSRTSDir
113 jsbn <- if usedBigInt stats
116 jsbn <- if usedBigInt stats
@@ -160,20 +163,21 @@ doHiddenClasses x =
160 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
163 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
161 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
164 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
162
165
163−doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
166+
164−doCodegen conf defs decls =
167+-- | Generate code for each declaration and collect stats.
165− let xs = map (doCodegenDecl conf defs) decls
168+-- LFunctions are turned into JS function declarations. They are
166− groupCGStats x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
169+-- preceded by a comment that gives their name. Constructor
167− , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
170+-- declarations are ignored.
168− , usedBigInt = usedBigInt x || usedBigInt y
171+doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
169− }
172+doCodegen defs = foldMap (doCodegenDecl defs)
170− in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
173+ where
171−
172−doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)
174+ doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
173−doCodegenDecl conf defs (LFun _ n args def) =
175+ doCodegenDecl defs (LFun _ name args def) =
174− let (ast, stats) = cgFun conf defs n args def
176+ let (ast, stats) = cgFun defs name args def
175− in (T.concat [jsStmt2Text (JsComment $ T.pack $ show n), "\n", jsStmt2Text ast], stats)
177+ fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
178+ in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
176−doCodegenDecl conf defs (LConstructor n i sz) = ("", emptyStats)
179+ doCodegenDecl defs (LConstructor n i sz) = ("", mempty)
180+
177
181
178seqJs :: [JsStmt] -> JsStmt
182seqJs :: [JsStmt] -> JsStmt
179seqJs [] = JsEmpty
183seqJs [] = JsEmpty
@@ -186,7 +190,6 @@ data CGBodyState = CGBodyState { defs :: Map Name LDecl
186 , currentFnNameAndArgs :: (Text, [Text])
190 , currentFnNameAndArgs :: (Text, [Text])
187 , usedArgsTailCallOptim :: Set (Text, Text)
191 , usedArgsTailCallOptim :: Set (Text, Text)
188 , isTailRec :: Bool
192 , isTailRec :: Bool
189− , conf :: CGConf
190 , usedITBig :: Bool
193 , usedITBig :: Bool
191 , partialApps :: Set Partial
194 , partialApps :: Set Partial
192 , hiddenCls :: Set HiddenClass
195 , hiddenCls :: Set HiddenClass
@@ -212,10 +215,6 @@ addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
212addUsedArgsTailCallOptim p =
215addUsedArgsTailCallOptim p =
213 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
216 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
214
217
215−getNewCGNames :: Int -> State CGBodyState [Text]
216−getNewCGNames n =
217− mapM (\_ -> getNewCGName) [1..n]
218−
219getConsId :: Name -> State CGBodyState (Int, Int)
218getConsId :: Name -> State CGBodyState (Int, Int)
220getConsId n =
219getConsId n =
221 do
220 do
@@ -238,8 +237,8 @@ data BodyResTarget = ReturnBT
238 | DecConstBT Text
237 | DecConstBT Text
239 | GetExpBT
238 | GetExpBT
240
239
241−cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
240+cgFun :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
242−cgFun cnf dfs n args def = do
241+cgFun dfs n args def = do
243 let fnName = jsName n
242 let fnName = jsName n
244 let argNames = map jsName args
243 let argNames = map jsName args
245 let ((decs, res),st) = runState
244 let ((decs, res),st) = runState
@@ -250,7 +249,6 @@ cgFun cnf dfs n args def = do
250 , currentFnNameAndArgs = (fnName, argNames)
249 , currentFnNameAndArgs = (fnName, argNames)
251 , usedArgsTailCallOptim = Set.empty
250 , usedArgsTailCallOptim = Set.empty
252 , isTailRec = False
251 , isTailRec = False
253− , conf = cnf
254 , usedITBig = False
252 , usedITBig = False
255 , partialApps = Set.empty
253 , partialApps = Set.empty
256 , hiddenCls = Set.empty
254 , hiddenCls = Set.empty
@@ -264,16 +262,6 @@ cgFun cnf dfs n args def = do
264 }
262 }
265 (fn, state')
263 (fn, state')
266
264
267−getSwitchJs :: JsExpr -> [LAlt] -> JsExpr
268−getSwitchJs x alts =
269− if any conCase alts then JsArrayProj (JsInt 0) x
270− else if any constBigIntCase alts then JsForeign "%0.toString()" [x]
271− else x
272− where conCase (LConCase _ _ _ _) = True
273− conCase _ = False
274− constBigIntCase (LConstCase (BI _) _) = True
275− constBigIntCase _ = False
276−
277addRT :: BodyResTarget -> JsExpr -> JsStmt
265addRT :: BodyResTarget -> JsExpr -> JsStmt
278addRT ReturnBT x = JsReturn x
266addRT ReturnBT x = JsReturn x
279addRT (DecBT n) x = JsDecLet n x
267addRT (DecBT n) x = JsDecLet n x