@@ -20,15 +20,16 @@ import IRTS.JavaScript.Name
2020import IRTS.JavaScript.PrimOp
2121import IRTS.JavaScript.Specialize
2222import IRTS.Lang
23−import IRTS.LangOpts
2423import IRTS.System
2524
25+import Control.Applicative (pure, (<$>))
2626import Control.Monad
2727import Control.Monad.Trans.State
28−import Data.List (nub)
28+import Data.Foldable (foldMap)
29+import Data.Generics.Uniplate.Data
30+import Data.List
2931import Data.Map.Strict (Map)
3032import qualified Data.Map.Strict as Map
31−import Data.Maybe (fromJust)
3233import Data.Set (Set)
3334import qualified Data.Set as Set
3435import Data.Text (Text)
@@ -38,23 +39,27 @@ import System.Directory (doesFileExist)
3839import System.Environment
3940import System.FilePath
4041
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)
4742
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.
4846data CGStats = CGStats { usedBigInt :: Bool
4947 , partialApplications :: Set Partial
5048 , hiddenClasses :: Set HiddenClass
5149 }
5250
53−emptyStats :: CGStats
54−emptyStats = CGStats { partialApplications = Set.empty
55− , hiddenClasses = Set.empty
56− , usedBigInt = False
57− }
51+-- If we generate code for two declarations we want to merge their code
52+-- generation stats.
53+instance Monoid CGStats where
54+ mempty = CGStats { partialApplications = Set.empty
55+ , hiddenClasses = Set.empty
56+ , usedBigInt = False
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+
5863
5964data CGConf = CGConf { header :: Text
6065 , footer :: Text
@@ -101,13 +106,11 @@ codegenJs conf ci =
101106 let defs' = Map.fromList $ liftDecls ci
102107 let defs = globlToCon defs'
103108 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
104− if debug then
105− do
109+ when debug $ do
106110 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
107111 putStrLn $ "Finished calculating used"
108− else pure ()
109112
110− let (out, stats) = doCodegen conf defs used
113+ let (out, stats) = doCodegen defs used
111114
112115 path <- getIdrisJSRTSDir
113116 jsbn <- if usedBigInt stats
@@ -160,20 +163,21 @@ doHiddenClasses x =
160163 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
161164 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
162165
163−doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
164−doCodegen conf defs decls =
165− let xs = map (doCodegenDecl conf defs) decls
166− groupCGStats x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
167− , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
168− , usedBigInt = usedBigInt x || usedBigInt y
169− }
170− in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
171−
172−doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)
173−doCodegenDecl conf defs (LFun _ n args def) =
174− let (ast, stats) = cgFun conf defs n args def
175− in (T.concat [jsStmt2Text (JsComment $ T.pack $ show n), "\n", jsStmt2Text ast], stats)
176−doCodegenDecl conf defs (LConstructor n i sz) = ("", emptyStats)
166+
167+-- | Generate code for each declaration and collect stats.
168+-- LFunctions are turned into JS function declarations. They are
169+-- preceded by a comment that gives their name. Constructor
170+-- declarations are ignored.
171+doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
172+doCodegen defs = foldMap (doCodegenDecl defs)
173+ where
174+ doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
175+ doCodegenDecl defs (LFun _ name args def) =
176+ let (ast, stats) = cgFun defs name args def
177+ fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
178+ in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
179+ doCodegenDecl defs (LConstructor n i sz) = ("", mempty)
180+
177181
178182seqJs :: [JsStmt] -> JsStmt
179183seqJs [] = JsEmpty
@@ -186,7 +190,6 @@ data CGBodyState = CGBodyState { defs :: Map Name LDecl
186190 , currentFnNameAndArgs :: (Text, [Text])
187191 , usedArgsTailCallOptim :: Set (Text, Text)
188192 , isTailRec :: Bool
189− , conf :: CGConf
190193 , usedITBig :: Bool
191194 , partialApps :: Set Partial
192195 , hiddenCls :: Set HiddenClass
@@ -212,10 +215,6 @@ addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
212215addUsedArgsTailCallOptim p =
213216 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
214217
215−getNewCGNames :: Int -> State CGBodyState [Text]
216−getNewCGNames n =
217− mapM (\_ -> getNewCGName) [1..n]
218−
219218getConsId :: Name -> State CGBodyState (Int, Int)
220219getConsId n =
221220 do
@@ -238,8 +237,8 @@ data BodyResTarget = ReturnBT
238237 | DecConstBT Text
239238 | GetExpBT
240239
241−cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
242−cgFun cnf dfs n args def = do
240+cgFun :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
241+cgFun dfs n args def = do
243242 let fnName = jsName n
244243 let argNames = map jsName args
245244 let ((decs, res),st) = runState
@@ -250,7 +249,6 @@ cgFun cnf dfs n args def = do
250249 , currentFnNameAndArgs = (fnName, argNames)
251250 , usedArgsTailCallOptim = Set.empty
252251 , isTailRec = False
253− , conf = cnf
254252 , usedITBig = False
255253 , partialApps = Set.empty
256254 , hiddenCls = Set.empty
@@ -264,16 +262,6 @@ cgFun cnf dfs n args def = do
264262 }
265263 (fn, state')
266264
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−
277265addRT :: BodyResTarget -> JsExpr -> JsStmt
278266addRT ReturnBT x = JsReturn x
279267addRT (DecBT n) x = JsDecLet n x