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