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