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