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