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