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