git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/IRTS/JavaScript/Codegen.hs
636 lines 24 kB history raw
1{-|
2Module : IRTS.JavaScript.Codegen
3Description : The JavaScript common code generator.
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE CPP, OverloadedStrings #-}
10module IRTS.JavaScript.Codegen( codegenJs
11 , CGConf(..)
12 , CGStats(..)
13 ) where
15import Idris.Core.TT
16import IRTS.CodegenCommon
17import IRTS.Exports
18import IRTS.JavaScript.AST
19import IRTS.JavaScript.LangTransforms
20import IRTS.JavaScript.Name
21import IRTS.JavaScript.PrimOp
22import IRTS.JavaScript.Specialize
23import IRTS.Lang
24import IRTS.System
26import Control.Applicative (pure, (<$>))
27import Control.Monad
28import Control.Monad.Trans.State
29import Data.Foldable (foldMap)
30import Data.Generics.Uniplate.Data
31import Data.List
32import Data.Map.Strict (Map)
33import qualified Data.Map.Strict as Map
34import Data.Set (Set)
35import qualified Data.Set as Set
36import Data.Text (Text)
37import qualified Data.Text as T
38import qualified Data.Text.IO as TIO
39import System.Directory (doesFileExist)
40import System.Environment
41import System.FilePath
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.
46data CGStats = CGStats { usedBigInt :: Bool
47 , partialApplications :: Set Partial
48 , hiddenClasses :: Set HiddenClass
49 }
51#if (MIN_VERSION_base(4,11,0))
52instance Semigroup CGStats where
53 (<>) = mappend
54#endif
56-- If we generate code for two declarations we want to merge their code
57-- generation stats.
58instance Monoid CGStats where
59 mempty = CGStats { partialApplications = Set.empty
60 , hiddenClasses = Set.empty
61 , usedBigInt = False
62 }
63 mappend x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
64 , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
65 , usedBigInt = usedBigInt x || usedBigInt y
66 }
69data CGConf = CGConf { header :: Text
70 , footer :: Text
71 , jsbnPath :: String
72 , extraRunTime :: String
73 }
76getInclude :: FilePath -> IO Text
77getInclude p =
78 do
79 libs <- getIdrisLibDir
80 let libPath = libs </> p
81 exitsInLib <- doesFileExist libPath
82 if exitsInLib then
83 TIO.readFile libPath
84 else TIO.readFile p
86getIncludes :: [FilePath] -> IO Text
87getIncludes l = do
88 incs <- mapM getInclude l
89 return $ T.intercalate "\n\n" incs
91includeLibs :: [String] -> String
92includeLibs =
93 let
94 repl '\\' = '_'
95 repl '/' = '_'
96 repl '.' = '_'
97 repl '-' = '_'
98 repl c = c
99 in
100 concatMap (\lib -> "var " ++ (repl <$> lib) ++ " = require(\"" ++ lib ++"\");\n")
102isYes :: Maybe String -> Bool
103isYes (Just "Y") = True
104isYes (Just "y") = True
105isYes _ = False
107makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
108makeExportDecls defs (Export _ _ e) =
109 concatMap makeExport e
110 where
111 uncurryF name argTy (Just args) retTy =
112 if length argTy == length args then
113 case (retTy, length args) of
114 (FIO _, 0) -> T.concat ["function(){return ", name, "()()}"]
115 _ -> name
116 else T.concat [ "function(){ return "
117 , name
118 , ".apply(this, Array.prototype.slice.call(arguments, 0,", T.pack $ show $ length args,"))"
119 , T.concat $ map (\x -> T.concat ["(arguments[", T.pack $ show x , "])"]) [length args .. (length argTy - 1)]
120 , "}"
121 ]
122 uncurryF name argTy Nothing retTy = name
124 makeExport (ExportData _) =
125 []
126 makeExport (ExportFun name (FStr exportname) retTy argTy) =
127 [T.concat [ T.pack $ exportname
128 , ": "
129 , uncurryF (jsName name) argTy (getArgList' name defs) retTy
130 ]
131 ]
133codegenJs :: CGConf -> CodeGenerator
134codegenJs conf ci =
135 do
136 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
137 let defs' = Map.fromList $ liftDecls ci
138 let defs = globlToCon defs'
139 let iface = interfaces ci
140 let used = if iface then
141 Map.elems $ removeDeadCode defs (getExpNames $ exportDecls ci)
142 else Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
143 when debug $ do
144 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
145 putStrLn $ "Finished calculating used"
147 let (out, stats) = doCodegen defs used
149 path <- getIdrisJSRTSDir
150 jsbn <- if usedBigInt stats
151 then TIO.readFile $ path </> jsbnPath conf
152 else return ""
154 runtimeCommon <- TIO.readFile $ path </> "Runtime-common.js"
155 extraRT <- TIO.readFile $ path </> (extraRunTime conf)
157 includes <- getIncludes $ includes ci
158 let libs = T.pack $ includeLibs $ compileLibs ci
159 TIO.writeFile (outputFile ci) $ T.concat [ header conf
160 , "\"use strict\";\n\n"
161 , "(function(){\n\n"
162 -- rts
163 , runtimeCommon, "\n"
164 , extraRT, "\n"
165 , jsbn, "\n"
166 -- external libraries
167 , includes, "\n"
168 , libs, "\n"
169 -- user code
170 , doPartials (partialApplications stats), "\n"
171 , doHiddenClasses (hiddenClasses stats), "\n"
172 , out, "\n"
173 , if iface then T.concat ["module.exports = {\n", T.intercalate ",\n" $ concatMap (makeExportDecls defs) (exportDecls ci), "\n};\n"]
174 else jsName (sMN 0 "runMain") `T.append` "();\n"
175 , "}.call(this))"
176 , footer conf
177 ]
179doPartials :: Set Partial -> Text
180doPartials x =
181 T.intercalate "\n" (map f $ Set.toList x)
182 where
183 f p@(Partial n i j) =
184 let vars1 = map (T.pack . ("x"++) . show) [1..i]
185 vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]
186 in jsStmt2Text $
187 JsFun (jsNamePartial p) vars1 $ JsReturn $
188 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
190doHiddenClasses :: Set HiddenClass -> Text
191doHiddenClasses x =
192 T.intercalate "\n" (map f $ Set.toList x)
193 where
194 f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
195 f p@(HiddenClass n id arity) =
196 let vars = map dataPartName $ take arity [1..]
197 in jsStmt2Text $
198 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
199 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
202-- | Generate code for each declaration and collect stats.
203-- LFunctions are turned into JS function declarations. They are
204-- preceded by a comment that gives their name. Constructor
205-- declarations are ignored.
206doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
207doCodegen defs = foldMap (doCodegenDecl defs)
208 where
209 doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
210 doCodegenDecl defs (LFun _ name args def) =
211 let (ast, stats) = cgFun defs name args def
212 fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
213 in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
214 doCodegenDecl defs (LConstructor n i sz) = ("", mempty)
217seqJs :: [JsStmt] -> JsStmt
218seqJs [] = JsEmpty
219seqJs (x:xs) = JsSeq x (seqJs xs)
222data CGBodyState = CGBodyState { defs :: Map Name LDecl
223 , lastIntName :: Int
224 , reWrittenNames :: Map.Map Name JsExpr
225 , currentFnNameAndArgs :: (Text, [Text])
226 , usedArgsTailCallOptim :: Set (Text, Text)
227 , isTailRec :: Bool
228 , usedITBig :: Bool
229 , partialApps :: Set Partial
230 , hiddenCls :: Set HiddenClass
231 }
233getNewCGName :: State CGBodyState Text
234getNewCGName =
235 do
236 st <- get
237 let v = lastIntName st + 1
238 put $ st {lastIntName = v}
239 return $ jsNameGenerated v
241addPartial :: Partial -> State CGBodyState ()
242addPartial p =
243 modify (\s -> s {partialApps = Set.insert p (partialApps s) })
245addHiddenClass :: HiddenClass -> State CGBodyState ()
246addHiddenClass p =
247 modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })
249addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
250addUsedArgsTailCallOptim p =
251 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
253getConsId :: Name -> State CGBodyState (Int, Int)
254getConsId n =
255 do
256 st <- get
257 case Map.lookup n (defs st) of
258 Just (LConstructor _ conId arity) -> pure (conId, arity)
259 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
261getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
262getArgList' n defs =
263 case Map.lookup n defs of
264 Just (LFun _ _ a _) -> Just a
265 _ -> Nothing
267getArgList :: Name -> State CGBodyState (Maybe [Name])
268getArgList n =
269 do
270 st <- get
271 pure $ getArgList' n (defs st)
273data BodyResTarget = ReturnBT
274 | DecBT Text
275 | SetBT Text
276 | DecConstBT Text
277 | GetExpBT
279cgFun :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
280cgFun dfs n args def = do
281 let fnName = jsName n
282 let argNames = map jsName args
283 let ((decs, res),st) = runState
284 (cgBody ReturnBT def)
285 (CGBodyState { defs = dfs
286 , lastIntName = 0
287 , reWrittenNames = Map.empty
288 , currentFnNameAndArgs = (fnName, argNames)
289 , usedArgsTailCallOptim = Set.empty
290 , isTailRec = False
291 , usedITBig = False
292 , partialApps = Set.empty
293 , hiddenCls = Set.empty
294 }
295 )
296 let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
297 let fn = JsFun fnName argNames body
298 let state' = CGStats { partialApplications = partialApps st
299 , hiddenClasses = hiddenCls st
300 , usedBigInt = usedITBig st
301 }
302 (fn, state')
304addRT :: BodyResTarget -> JsExpr -> JsStmt
305addRT ReturnBT x = JsReturn x
306addRT (DecBT n) x = JsDecLet n x
307addRT (DecConstBT n) x = JsDecConst n x
308addRT (SetBT n) x = JsSet (JsVar n) x
309addRT GetExpBT x = JsExprStmt x
311declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
312declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsDecLet x (JsVar y) ) (Set.toList x)
314tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
315tailCallOptimRefreshArgs [] s = ((JsEmpty, JsEmpty), Set.empty)
316tailCallOptimRefreshArgs ((n,x):r) s =
317 let ((y1,y2), y3) = tailCallOptimRefreshArgs r (Set.insert n s) --
318 in if Set.null $ (Set.fromList [ z | z <- universeBi x ]) `Set.intersection` s then
319 ((y1, jsSetVar n x `JsSeq` y2), y3)
320 else
321 let n' = jsTailCallOptimName n
322 in ((jsSetVar n' x `JsSeq` y1, jsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)
324cgName :: Name -> State CGBodyState JsExpr
325cgName b = do
326 st <- get
327 case Map.lookup b (reWrittenNames st) of
328 Just e -> pure e
329 _ -> pure $ JsVar $ jsName b
331cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
332cgBody rt expr =
333 case expr of
334 (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
335 | (ff == qualifyN "Prelude.Bool" "False" &&
336 tt == qualifyN "Prelude.Bool" "True") ->
337 case (Map.lookup oper primDB) of
338 Just (needBI, pti, c) | pti == PTBool -> do
339 z <- mapM (cgBody GetExpBT) [x, y]
340 when needBI setUsedITBig
341 let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z
342 pure $ (concat $ map fst z, addRT rt res)
343 _ -> cgBody' rt expr
344 (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])
345 | (ff == qualifyN "Prelude.Bool" "False" &&
346 tt == qualifyN "Prelude.Bool" "True") -> do
347 (d, v) <- cgBody GetExpBT e
348 test <- formConTest n (jsStmt2Expr v)
349 pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
350 (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])
351 | (ff == qualifyN "Prelude.Bool" "False" &&
352 tt == qualifyN "Prelude.Bool" "True") -> do
353 (d, v) <- cgBody GetExpBT e
354 test <- formConTest n (jsStmt2Expr v)
355 pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
356 (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
357 | (ff == qualifyN "Prelude.Bool" "False" &&
358 tt == qualifyN "Prelude.Bool" "True") -> do
359 (d, v) <- cgBody GetExpBT e
360 test <- formConTest n (jsStmt2Expr v)
361 pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
362 (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])
363 | (ff == qualifyN "Prelude.Bool" "False" &&
364 tt == qualifyN "Prelude.Bool" "True") -> do
365 (d, v) <- cgBody GetExpBT e
366 test <- formConTest n (jsStmt2Expr v)
367 pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
368 (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
369 | (ff == qualifyN "Prelude.Bool" "False" &&
370 tt == qualifyN "Prelude.Bool" "True") ->
371 cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt]
372 expr -> cgBody' rt expr
374cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
375cgBody' rt (LV n) =
376 do
377 argsFn <- getArgList n
378 case argsFn of
379 Just a -> cgBody' rt (LApp False (LV n) [])
380 Nothing -> do
381 n' <- cgName n
382 pure $ ([], addRT rt n')
383cgBody' rt (LApp tailcall (LV fn) args) =
384 do
385 let fname = jsName fn
386 st <- get
387 let (currFn, argN) = currentFnNameAndArgs st
388 z <- mapM (cgBody GetExpBT) args
389 let argVals = map (jsStmt2Expr . snd) z
390 let preDecs = concat $ map fst z
391 case (fname == currFn && (length args) == (length argN), rt) of
392 (True, ReturnBT) ->
393 do
394 modify (\x-> x {isTailRec = True})
395 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
396 addUsedArgsTailCallOptim y3
397 pure (preDecs, y1 `JsSeq` y2)
398 _ -> do
399 app <- formApp fn argVals
400 pure (preDecs, addRT rt app)
402cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV n) args)
403cgBody' rt (LLazyApp n args) =
404 do
405 (d,v) <- cgBody ReturnBT (LApp False (LV n) args)
406 pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
407cgBody' rt (LForce e) =
408 do
409 (d,v) <- cgBody GetExpBT e
410 pure (d, addRT rt $ JsForce $ jsStmt2Expr v)
411cgBody' rt (LLet n v sc) =
412 do
413 (d1, v1) <- cgBody (DecConstBT $ jsName n) v
414 (d2, v2) <- cgBody rt sc
415 pure $ ((d1 ++ v1 : d2), v2)
416cgBody' rt (LProj e i) =
417 do
418 (d, v) <- cgBody GetExpBT e
419 pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)
420cgBody' rt (LCon _ conId n args) =
421 do
422 z <- mapM (cgBody GetExpBT) args
423 con <- formCon n (map (jsStmt2Expr . snd) z)
424 pure $ (concat $ map fst z, addRT rt con)
425cgBody' rt (LCase _ e alts) = do
426 (d, v) <- cgBody GetExpBT e
427 resName <- getNewCGName
428 (decSw, entry) <-
429 case (all altHasNoProj alts && length alts <= 2, v) of
430 (True, _) -> pure (JsEmpty, jsStmt2Expr v)
431 (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v)
432 _ -> do
433 swName <- getNewCGName
434 pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)
435 sw' <- cgIfTree rt resName entry alts
436 let sw =
437 case sw' of
438 (Just x) -> x
439 Nothing -> JsExprStmt JsNull
440 case rt of
441 ReturnBT -> pure (d ++ [decSw], sw)
442 (DecBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
443 (DecConstBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
444 (SetBT nvar) -> pure (d ++ [decSw], sw)
445 GetExpBT ->
446 pure
447 (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName)
448cgBody' rt (LConst c) =
449 do
450 cst <- cgConst c
451 pure ([], (addRT rt) $ cst)
452cgBody' rt (LOp op args) =
453 do
454 z <- mapM (cgBody GetExpBT) args
455 res <- cgOp op (map (jsStmt2Expr . snd) z)
456 pure $ (concat $ map fst z, addRT rt $ res)
457cgBody' rt LNothing = pure ([], addRT rt JsNull)
458cgBody' rt (LError x) = pure ([], JsError $ JsStr x)
459cgBody' rt x@(LForeign dres (FStr code) args ) =
460 do
461 z <- mapM (cgBody GetExpBT) (map snd args)
462 jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z))
463 jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs
464 pure $ (concat $ map fst z, addRT rt $ jsDres)
465cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
467altsRT :: Text -> BodyResTarget -> BodyResTarget
468altsRT rn ReturnBT = ReturnBT
469altsRT rn (DecBT n) = SetBT n
470altsRT rn (SetBT n) = SetBT n
471altsRT rn (DecConstBT n) = SetBT n
472altsRT rn GetExpBT = SetBT rn
474altHasNoProj :: LAlt -> Bool
475altHasNoProj (LConCase _ _ args _) = args == []
476altHasNoProj _ = True
478formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
479formApp fn argVals = case specialCall fn of
480 Just (arity, g) | arity == length argVals -> pure $ g argVals
481 _ -> do
482 argsFn <- getArgList fn
483 fname <- cgName fn
484 case argsFn of
485 Nothing -> pure $ jsCurryApp fname argVals
486 Just agFn -> do
487 let lenAgFn = length agFn
488 let lenArgs = length argVals
489 case compare lenAgFn lenArgs of
490 EQ -> pure $ JsApp fname argVals
491 LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)
492 GT -> do
493 let part = Partial fn lenArgs lenAgFn
494 addPartial part
495 pure $ jsAppN (jsNamePartial part) argVals
497formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
498formCon n args = do
499 case specialCased n of
500 Just (ctor, test, match) -> pure $ ctor args
501 Nothing -> do
502 (conId, arity) <- getConsId n
503 let hc = HiddenClass n conId arity
504 addHiddenClass hc
505 pure $ if (arity > 0)
506 then JsNew (JsVar $ jsNameHiddenClass hc) args
507 else JsVar $ jsNameHiddenClass hc
509formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
510formConTest n x = do
511 case specialCased n of
512 Just (ctor, test, match) -> pure $ test x
513 Nothing -> do
514 (conId, arity) <- getConsId n
515 pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
516 -- if (arity > 0)
517 -- then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
518 -- else pure $ JsBinOp "===" x (JsInt conId)
520formProj :: Name -> JsExpr -> Int -> JsExpr
521formProj n v i =
522 case specialCased n of
523 Just (ctor, test, proj) -> proj v i
524 Nothing -> JsProp v (dataPartName i)
526smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
527smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
528smartif cond conseq Nothing = conseq
530formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
531formConstTest scrvar t = case t of
532 BI _ -> do
533 t' <- cgConst t
534 cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
535 _ -> do
536 t' <- cgConst t
537 pure $ JsBinOp "===" scrvar t'
539cgIfTree :: BodyResTarget
540 -> Text
541 -> JsExpr
542 -> [LAlt]
543 -> State CGBodyState (Maybe JsStmt)
544cgIfTree _ _ _ [] = pure Nothing
545cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
546 (d, v) <- cgBody (altsRT resName rt) exp
547 alternatives <- cgIfTree rt resName scrvar r
548 test <- formConstTest scrvar t
549 pure $ Just $
550 smartif test (JsSeq (seqJs d) v) alternatives
551cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
552 (d, v) <- cgBody (altsRT resName rt) exp
553 pure $ Just $ JsSeq (seqJs d) v
554cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do
555 alternatives <- cgIfTree rt resName scrvar r
556 test <- formConTest n scrvar
557 st <- get
558 let rwn = reWrittenNames st
559 put $
560 st
561 { reWrittenNames =
562 foldl
563 (\m (n, j) -> Map.insert n (formProj n scrvar j) m)
564 rwn
565 (zip args [1 ..])
566 }
567 (d, v) <- cgBody (altsRT resName rt) exp
568 st1 <- get
569 put $ st1 {reWrittenNames = rwn}
570 let branchBody = JsSeq (seqJs d) v
571 pure $ Just $ smartif test branchBody alternatives
574cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
575cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v
576cgForeignArg (FCon (UN "JS_Str"), v) = pure v
577cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v
578cgForeignArg (FCon (UN "JS_Unit"), v) = pure v
579cgForeignArg (FCon (UN "JS_Float"), v) = pure v
580cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =
581 pure f
582cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =
583 do
584 jsx <- cgForeignArg (a, JsVar "x")
585 jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]
586 pure $ JsLambda ["x"] $ JsReturn jsres
587cgForeignArg (desc, _) =
588 do
589 st <- get
590 error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
592cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
593cgForeignRes (FApp (UN "JS_IntT") _) x = pure x
594cgForeignRes (FCon (UN "JS_Unit")) x = pure x
595cgForeignRes (FCon (UN "JS_Str")) x = pure x
596cgForeignRes (FCon (UN "JS_Ptr")) x = pure x
597cgForeignRes (FCon (UN "JS_Float")) x = pure x
598cgForeignRes desc val =
599 do
600 st <- get
601 error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
603setUsedITBig :: State CGBodyState ()
604setUsedITBig = modify (\s -> s {usedITBig = True})
607cgConst :: Const -> State CGBodyState JsExpr
608cgConst (I i) = pure $ JsInt i
609cgConst (BI i) =
610 do
611 setUsedITBig
612 pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)" [JsStr $ show i]
613cgConst (Ch c) = pure $ JsStr [c]
614cgConst (Str s) = pure $ JsStr s
615cgConst (Fl f) = pure $ JsDouble f
616cgConst (B8 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFF") []
617cgConst (B16 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFFFF") []
618cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []
619cgConst (B64 x) =
620 do
621 setUsedITBig
622 pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
623cgConst x | isTypeConst x = pure $ JsInt 0
624cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
626cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
627cgOp = cgOp' PTAny
629cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
630cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
631cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
632cgOp' pt op exps = case Map.lookup op primDB of
633 Just (useBigInt, pti, combinator) -> do
634 when useBigInt setUsedITBig
635 pure $ jsPrimCoerce pti pt $ combinator exps
636 Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")