git.iko.soy/Idris-dev
on f07ebbf help sign in
Idris-dev/src/IRTS/JavaScript/Codegen.hs
633 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) =
112 if length argTy == length args then name
113 else T.concat [ "function(){ return "
114 , name
115 , ".apply(this, Array.prototype.slice.call(arguments, 0,", T.pack $ show $ length args,"))"
116 , T.concat $ map (\x -> T.concat ["(arguments[", T.pack $ show x , "])"]) [length args .. (length argTy - 1)]
117 , "}"
118 ]
119 uncurryF name argTy Nothing = name
121 makeExport (ExportData _) =
122 []
123 makeExport (ExportFun name (FStr exportname) retTy argTy) =
124 [T.concat [ T.pack $ exportname
125 , ": "
126 , uncurryF (jsName name) argTy (getArgList' name defs)
127 ]
128 ]
130codegenJs :: CGConf -> CodeGenerator
131codegenJs conf ci =
132 do
133 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
134 let defs' = Map.fromList $ liftDecls ci
135 let defs = globlToCon defs'
136 let iface = interfaces ci
137 let used = if iface then
138 Map.elems $ removeDeadCode defs (getExpNames $ exportDecls ci)
139 else Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
140 when debug $ do
141 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
142 putStrLn $ "Finished calculating used"
144 let (out, stats) = doCodegen defs used
146 path <- getIdrisJSRTSDir
147 jsbn <- if usedBigInt stats
148 then TIO.readFile $ path </> jsbnPath conf
149 else return ""
151 runtimeCommon <- TIO.readFile $ path </> "Runtime-common.js"
152 extraRT <- TIO.readFile $ path </> (extraRunTime conf)
154 includes <- getIncludes $ includes ci
155 let libs = T.pack $ includeLibs $ compileLibs ci
156 TIO.writeFile (outputFile ci) $ T.concat [ header conf
157 , "\"use strict\";\n\n"
158 , "(function(){\n\n"
159 -- rts
160 , runtimeCommon, "\n"
161 , extraRT, "\n"
162 , jsbn, "\n"
163 -- external libraries
164 , includes, "\n"
165 , libs, "\n"
166 -- user code
167 , doPartials (partialApplications stats), "\n"
168 , doHiddenClasses (hiddenClasses stats), "\n"
169 , out, "\n"
170 , if iface then T.concat ["module.exports = {\n", T.intercalate ",\n" $ concatMap (makeExportDecls defs) (exportDecls ci), "\n};\n"]
171 else jsName (sMN 0 "runMain") `T.append` "();\n"
172 , "}.call(this))"
173 , footer conf
174 ]
176doPartials :: Set Partial -> Text
177doPartials x =
178 T.intercalate "\n" (map f $ Set.toList x)
179 where
180 f p@(Partial n i j) =
181 let vars1 = map (T.pack . ("x"++) . show) [1..i]
182 vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]
183 in jsStmt2Text $
184 JsFun (jsNamePartial p) vars1 $ JsReturn $
185 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
187doHiddenClasses :: Set HiddenClass -> Text
188doHiddenClasses x =
189 T.intercalate "\n" (map f $ Set.toList x)
190 where
191 f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
192 f p@(HiddenClass n id arity) =
193 let vars = map dataPartName $ take arity [1..]
194 in jsStmt2Text $
195 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
196 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
199-- | Generate code for each declaration and collect stats.
200-- LFunctions are turned into JS function declarations. They are
201-- preceded by a comment that gives their name. Constructor
202-- declarations are ignored.
203doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
204doCodegen defs = foldMap (doCodegenDecl defs)
205 where
206 doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
207 doCodegenDecl defs (LFun _ name args def) =
208 let (ast, stats) = cgFun defs name args def
209 fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
210 in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
211 doCodegenDecl defs (LConstructor n i sz) = ("", mempty)
214seqJs :: [JsStmt] -> JsStmt
215seqJs [] = JsEmpty
216seqJs (x:xs) = JsSeq x (seqJs xs)
219data CGBodyState = CGBodyState { defs :: Map Name LDecl
220 , lastIntName :: Int
221 , reWrittenNames :: Map.Map Name JsExpr
222 , currentFnNameAndArgs :: (Text, [Text])
223 , usedArgsTailCallOptim :: Set (Text, Text)
224 , isTailRec :: Bool
225 , usedITBig :: Bool
226 , partialApps :: Set Partial
227 , hiddenCls :: Set HiddenClass
228 }
230getNewCGName :: State CGBodyState Text
231getNewCGName =
232 do
233 st <- get
234 let v = lastIntName st + 1
235 put $ st {lastIntName = v}
236 return $ jsNameGenerated v
238addPartial :: Partial -> State CGBodyState ()
239addPartial p =
240 modify (\s -> s {partialApps = Set.insert p (partialApps s) })
242addHiddenClass :: HiddenClass -> State CGBodyState ()
243addHiddenClass p =
244 modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })
246addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
247addUsedArgsTailCallOptim p =
248 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
250getConsId :: Name -> State CGBodyState (Int, Int)
251getConsId n =
252 do
253 st <- get
254 case Map.lookup n (defs st) of
255 Just (LConstructor _ conId arity) -> pure (conId, arity)
256 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
258getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
259getArgList' n defs =
260 case Map.lookup n defs of
261 Just (LFun _ _ a _) -> Just a
262 _ -> Nothing
264getArgList :: Name -> State CGBodyState (Maybe [Name])
265getArgList n =
266 do
267 st <- get
268 pure $ getArgList' n (defs st)
270data BodyResTarget = ReturnBT
271 | DecBT Text
272 | SetBT Text
273 | DecConstBT Text
274 | GetExpBT
276cgFun :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
277cgFun dfs n args def = do
278 let fnName = jsName n
279 let argNames = map jsName args
280 let ((decs, res),st) = runState
281 (cgBody ReturnBT def)
282 (CGBodyState { defs = dfs
283 , lastIntName = 0
284 , reWrittenNames = Map.empty
285 , currentFnNameAndArgs = (fnName, argNames)
286 , usedArgsTailCallOptim = Set.empty
287 , isTailRec = False
288 , usedITBig = False
289 , partialApps = Set.empty
290 , hiddenCls = Set.empty
291 }
292 )
293 let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
294 let fn = JsFun fnName argNames body
295 let state' = CGStats { partialApplications = partialApps st
296 , hiddenClasses = hiddenCls st
297 , usedBigInt = usedITBig st
298 }
299 (fn, state')
301addRT :: BodyResTarget -> JsExpr -> JsStmt
302addRT ReturnBT x = JsReturn x
303addRT (DecBT n) x = JsDecLet n x
304addRT (DecConstBT n) x = JsDecConst n x
305addRT (SetBT n) x = JsSet (JsVar n) x
306addRT GetExpBT x = JsExprStmt x
308declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
309declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsDecLet x (JsVar y) ) (Set.toList x)
311tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
312tailCallOptimRefreshArgs [] s = ((JsEmpty, JsEmpty), Set.empty)
313tailCallOptimRefreshArgs ((n,x):r) s =
314 let ((y1,y2), y3) = tailCallOptimRefreshArgs r (Set.insert n s) --
315 in if Set.null $ (Set.fromList [ z | z <- universeBi x ]) `Set.intersection` s then
316 ((y1, jsSetVar n x `JsSeq` y2), y3)
317 else
318 let n' = jsTailCallOptimName n
319 in ((jsSetVar n' x `JsSeq` y1, jsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)
321cgName :: Name -> State CGBodyState JsExpr
322cgName b = do
323 st <- get
324 case Map.lookup b (reWrittenNames st) of
325 Just e -> pure e
326 _ -> pure $ JsVar $ jsName b
328cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
329cgBody rt expr =
330 case expr of
331 (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
332 | (ff == qualifyN "Prelude.Bool" "False" &&
333 tt == qualifyN "Prelude.Bool" "True") ->
334 case (Map.lookup oper primDB) of
335 Just (needBI, pti, c) | pti == PTBool -> do
336 z <- mapM (cgBody GetExpBT) [x, y]
337 when needBI setUsedITBig
338 let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z
339 pure $ (concat $ map fst z, addRT rt res)
340 _ -> cgBody' rt expr
341 (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])
342 | (ff == qualifyN "Prelude.Bool" "False" &&
343 tt == qualifyN "Prelude.Bool" "True") -> do
344 (d, v) <- cgBody GetExpBT e
345 test <- formConTest n (jsStmt2Expr v)
346 pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
347 (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])
348 | (ff == qualifyN "Prelude.Bool" "False" &&
349 tt == qualifyN "Prelude.Bool" "True") -> do
350 (d, v) <- cgBody GetExpBT e
351 test <- formConTest n (jsStmt2Expr v)
352 pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
353 (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
354 | (ff == qualifyN "Prelude.Bool" "False" &&
355 tt == qualifyN "Prelude.Bool" "True") -> do
356 (d, v) <- cgBody GetExpBT e
357 test <- formConTest n (jsStmt2Expr v)
358 pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
359 (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])
360 | (ff == qualifyN "Prelude.Bool" "False" &&
361 tt == qualifyN "Prelude.Bool" "True") -> do
362 (d, v) <- cgBody GetExpBT e
363 test <- formConTest n (jsStmt2Expr v)
364 pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
365 (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
366 | (ff == qualifyN "Prelude.Bool" "False" &&
367 tt == qualifyN "Prelude.Bool" "True") ->
368 cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt]
369 expr -> cgBody' rt expr
371cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
372cgBody' rt (LV n) =
373 do
374 argsFn <- getArgList n
375 case argsFn of
376 Just a -> cgBody' rt (LApp False (LV n) [])
377 Nothing -> do
378 n' <- cgName n
379 pure $ ([], addRT rt n')
380cgBody' rt (LApp tailcall (LV fn) args) =
381 do
382 let fname = jsName fn
383 st <- get
384 let (currFn, argN) = currentFnNameAndArgs st
385 z <- mapM (cgBody GetExpBT) args
386 let argVals = map (jsStmt2Expr . snd) z
387 let preDecs = concat $ map fst z
388 case (fname == currFn && (length args) == (length argN), rt) of
389 (True, ReturnBT) ->
390 do
391 modify (\x-> x {isTailRec = True})
392 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
393 addUsedArgsTailCallOptim y3
394 pure (preDecs, y1 `JsSeq` y2)
395 _ -> do
396 app <- formApp fn argVals
397 pure (preDecs, addRT rt app)
399cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV n) args)
400cgBody' rt (LLazyApp n args) =
401 do
402 (d,v) <- cgBody ReturnBT (LApp False (LV n) args)
403 pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
404cgBody' rt (LForce e) =
405 do
406 (d,v) <- cgBody GetExpBT e
407 pure (d, addRT rt $ JsForce $ jsStmt2Expr v)
408cgBody' rt (LLet n v sc) =
409 do
410 (d1, v1) <- cgBody (DecConstBT $ jsName n) v
411 (d2, v2) <- cgBody rt sc
412 pure $ ((d1 ++ v1 : d2), v2)
413cgBody' rt (LProj e i) =
414 do
415 (d, v) <- cgBody GetExpBT e
416 pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)
417cgBody' rt (LCon _ conId n args) =
418 do
419 z <- mapM (cgBody GetExpBT) args
420 con <- formCon n (map (jsStmt2Expr . snd) z)
421 pure $ (concat $ map fst z, addRT rt con)
422cgBody' rt (LCase _ e alts) = do
423 (d, v) <- cgBody GetExpBT e
424 resName <- getNewCGName
425 (decSw, entry) <-
426 case (all altHasNoProj alts && length alts <= 2, v) of
427 (True, _) -> pure (JsEmpty, jsStmt2Expr v)
428 (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v)
429 _ -> do
430 swName <- getNewCGName
431 pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)
432 sw' <- cgIfTree rt resName entry alts
433 let sw =
434 case sw' of
435 (Just x) -> x
436 Nothing -> JsExprStmt JsNull
437 case rt of
438 ReturnBT -> pure (d ++ [decSw], sw)
439 (DecBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
440 (DecConstBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
441 (SetBT nvar) -> pure (d ++ [decSw], sw)
442 GetExpBT ->
443 pure
444 (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName)
445cgBody' rt (LConst c) =
446 do
447 cst <- cgConst c
448 pure ([], (addRT rt) $ cst)
449cgBody' rt (LOp op args) =
450 do
451 z <- mapM (cgBody GetExpBT) args
452 res <- cgOp op (map (jsStmt2Expr . snd) z)
453 pure $ (concat $ map fst z, addRT rt $ res)
454cgBody' rt LNothing = pure ([], addRT rt JsNull)
455cgBody' rt (LError x) = pure ([], JsError $ JsStr x)
456cgBody' rt x@(LForeign dres (FStr code) args ) =
457 do
458 z <- mapM (cgBody GetExpBT) (map snd args)
459 jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z))
460 jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs
461 pure $ (concat $ map fst z, addRT rt $ jsDres)
462cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
464altsRT :: Text -> BodyResTarget -> BodyResTarget
465altsRT rn ReturnBT = ReturnBT
466altsRT rn (DecBT n) = SetBT n
467altsRT rn (SetBT n) = SetBT n
468altsRT rn (DecConstBT n) = SetBT n
469altsRT rn GetExpBT = SetBT rn
471altHasNoProj :: LAlt -> Bool
472altHasNoProj (LConCase _ _ args _) = args == []
473altHasNoProj _ = True
475formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
476formApp fn argVals = case specialCall fn of
477 Just (arity, g) | arity == length argVals -> pure $ g argVals
478 _ -> do
479 argsFn <- getArgList fn
480 fname <- cgName fn
481 case argsFn of
482 Nothing -> pure $ jsCurryApp fname argVals
483 Just agFn -> do
484 let lenAgFn = length agFn
485 let lenArgs = length argVals
486 case compare lenAgFn lenArgs of
487 EQ -> pure $ JsApp fname argVals
488 LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)
489 GT -> do
490 let part = Partial fn lenArgs lenAgFn
491 addPartial part
492 pure $ jsAppN (jsNamePartial part) argVals
494formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
495formCon n args = do
496 case specialCased n of
497 Just (ctor, test, match) -> pure $ ctor args
498 Nothing -> do
499 (conId, arity) <- getConsId n
500 let hc = HiddenClass n conId arity
501 addHiddenClass hc
502 pure $ if (arity > 0)
503 then JsNew (JsVar $ jsNameHiddenClass hc) args
504 else JsVar $ jsNameHiddenClass hc
506formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
507formConTest n x = do
508 case specialCased n of
509 Just (ctor, test, match) -> pure $ test x
510 Nothing -> do
511 (conId, arity) <- getConsId n
512 pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
513 -- if (arity > 0)
514 -- then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
515 -- else pure $ JsBinOp "===" x (JsInt conId)
517formProj :: Name -> JsExpr -> Int -> JsExpr
518formProj n v i =
519 case specialCased n of
520 Just (ctor, test, proj) -> proj v i
521 Nothing -> JsProp v (dataPartName i)
523smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
524smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
525smartif cond conseq Nothing = conseq
527formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
528formConstTest scrvar t = case t of
529 BI _ -> do
530 t' <- cgConst t
531 cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
532 _ -> do
533 t' <- cgConst t
534 pure $ JsBinOp "===" scrvar t'
536cgIfTree :: BodyResTarget
537 -> Text
538 -> JsExpr
539 -> [LAlt]
540 -> State CGBodyState (Maybe JsStmt)
541cgIfTree _ _ _ [] = pure Nothing
542cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
543 (d, v) <- cgBody (altsRT resName rt) exp
544 alternatives <- cgIfTree rt resName scrvar r
545 test <- formConstTest scrvar t
546 pure $ Just $
547 smartif test (JsSeq (seqJs d) v) alternatives
548cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
549 (d, v) <- cgBody (altsRT resName rt) exp
550 pure $ Just $ JsSeq (seqJs d) v
551cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do
552 alternatives <- cgIfTree rt resName scrvar r
553 test <- formConTest n scrvar
554 st <- get
555 let rwn = reWrittenNames st
556 put $
557 st
558 { reWrittenNames =
559 foldl
560 (\m (n, j) -> Map.insert n (formProj n scrvar j) m)
561 rwn
562 (zip args [1 ..])
563 }
564 (d, v) <- cgBody (altsRT resName rt) exp
565 st1 <- get
566 put $ st1 {reWrittenNames = rwn}
567 let branchBody = JsSeq (seqJs d) v
568 pure $ Just $ smartif test branchBody alternatives
571cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
572cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v
573cgForeignArg (FCon (UN "JS_Str"), v) = pure v
574cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v
575cgForeignArg (FCon (UN "JS_Unit"), v) = pure v
576cgForeignArg (FCon (UN "JS_Float"), v) = pure v
577cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =
578 pure f
579cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =
580 do
581 jsx <- cgForeignArg (a, JsVar "x")
582 jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]
583 pure $ JsLambda ["x"] $ JsReturn jsres
584cgForeignArg (desc, _) =
585 do
586 st <- get
587 error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
589cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
590cgForeignRes (FApp (UN "JS_IntT") _) x = pure x
591cgForeignRes (FCon (UN "JS_Unit")) x = pure x
592cgForeignRes (FCon (UN "JS_Str")) x = pure x
593cgForeignRes (FCon (UN "JS_Ptr")) x = pure x
594cgForeignRes (FCon (UN "JS_Float")) x = pure x
595cgForeignRes desc val =
596 do
597 st <- get
598 error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
600setUsedITBig :: State CGBodyState ()
601setUsedITBig = modify (\s -> s {usedITBig = True})
604cgConst :: Const -> State CGBodyState JsExpr
605cgConst (I i) = pure $ JsInt i
606cgConst (BI i) =
607 do
608 setUsedITBig
609 pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)" [JsStr $ show i]
610cgConst (Ch c) = pure $ JsStr [c]
611cgConst (Str s) = pure $ JsStr s
612cgConst (Fl f) = pure $ JsDouble f
613cgConst (B8 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFF") []
614cgConst (B16 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFFFF") []
615cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []
616cgConst (B64 x) =
617 do
618 setUsedITBig
619 pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
620cgConst x | isTypeConst x = pure $ JsInt 0
621cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
623cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
624cgOp = cgOp' PTAny
626cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
627cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
628cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
629cgOp' pt op exps = case Map.lookup op primDB of
630 Just (useBigInt, pti, combinator) -> do
631 when useBigInt setUsedITBig
632 pure $ jsPrimCoerce pti pt $ combinator exps
633 Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")