git.iko.soy/Idris-dev
on 803dd59 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1207 lines 41 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
4import Idris.AbsSyntax hiding (TypeCase)
5import IRTS.Bytecode
6import IRTS.Lang
7import IRTS.Simplified
8import IRTS.CodegenCommon
9import Idris.Core.TT
10import Paths_idris
11import Util.System
13import Control.Arrow
14import Control.Applicative ((<$>), (<*>), pure)
15import Data.Char
16import Numeric
17import Data.List
18import Data.Maybe
19import Data.Word
20import System.IO
21import System.Directory
24idrNamespace :: String
25idrNamespace = "__IDR__"
26idrRTNamespace = "__IDRRT__"
27idrLTNamespace = "__IDRLT__"
28idrCTRNamespace = "__IDRCTR__"
31data JSTarget = Node | JavaScript deriving Eq
34data JSType = JSIntTy
35 | JSStringTy
36 | JSIntegerTy
37 | JSFloatTy
38 | JSCharTy
39 | JSPtrTy
40 | JSForgotTy
41 deriving Eq
44data JSInteger = JSBigZero
45 | JSBigOne
46 | JSBigInt Integer
47 | JSBigIntExpr JS
48 deriving Eq
51data JSNum = JSInt Int
52 | JSFloat Double
53 | JSInteger JSInteger
54 deriving Eq
57data JSWord = JSWord8 Word8
58 | JSWord16 Word16
59 | JSWord32 Word32
60 | JSWord64 Word64
61 deriving Eq
64data JSAnnotation = JSConstructor deriving Eq
67instance Show JSAnnotation where
68 show JSConstructor = "constructor"
71data JS = JSRaw String
72 | JSIdent String
73 | JSFunction [String] JS
74 | JSType JSType
75 | JSSeq [JS]
76 | JSReturn JS
77 | JSApp JS [JS]
78 | JSNew String [JS]
79 | JSError String
80 | JSBinOp String JS JS
81 | JSPreOp String JS
82 | JSPostOp String JS
83 | JSProj JS String
84 | JSNull
85 | JSThis
86 | JSTrue
87 | JSFalse
88 | JSArray [JS]
89 | JSString String
90 | JSNum JSNum
91 | JSWord JSWord
92 | JSAssign JS JS
93 | JSAlloc String (Maybe JS)
94 | JSIndex JS JS
95 | JSSwitch JS [(JS, JS)] (Maybe JS)
96 | JSCond [(JS, JS)]
97 | JSTernary JS JS JS
98 | JSParens JS
99 | JSWhile JS JS
100 | JSFFI String [JS]
101 | JSAnnotation JSAnnotation JS
102 | JSNoop
103 deriving Eq
106data FFI = FFICode Char | FFIArg Int | FFIError String
108compileJS :: JS -> String
109compileJS JSNoop = ""
111compileJS (JSAnnotation annotation js) =
112 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
114{-compileJS (JSFFI raw args) =-}
115 {-ffi raw (map compileJS args)-}
117compileJS (JSRaw code) =
118 code
120compileJS (JSIdent ident) =
121 ident
123compileJS (JSFunction args body) =
124 "function("
125 ++ intercalate "," args
126 ++ "){\n"
127 ++ compileJS body
128 ++ "\n}\n"
130compileJS (JSType ty)
131 | JSIntTy <- ty = idrRTNamespace ++ "Int"
132 | JSStringTy <- ty = idrRTNamespace ++ "String"
133 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
134 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
135 | JSCharTy <- ty = idrRTNamespace ++ "Char"
136 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
137 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
139compileJS (JSSeq seq) =
140 intercalate ";\n" (map compileJS $ filter (/= JSNoop) seq) ++ ";"
142compileJS (JSReturn val) =
143 "return " ++ compileJS val
145compileJS (JSApp lhs rhs)
146 | JSFunction {} <- lhs =
147 concat ["(", compileJS lhs, ")(", args, ")"]
148 | otherwise =
149 concat [compileJS lhs, "(", args, ")"]
150 where args :: String
151 args = intercalate "," $ map compileJS rhs
153compileJS (JSNew name args) =
154 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
156compileJS (JSError exc) =
157 "throw new Error(\"" ++ exc ++ "\")"
159compileJS (JSBinOp op lhs rhs) =
160 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
162compileJS (JSPreOp op val) =
163 op ++ compileJS val
165compileJS (JSProj obj field)
166 | JSFunction {} <- obj =
167 concat ["(", compileJS obj, ").", field]
168 | JSAssign {} <- obj =
169 concat ["(", compileJS obj, ").", field]
170 | otherwise =
171 compileJS obj ++ '.' : field
173compileJS JSNull =
174 "null"
176compileJS JSThis =
177 "this"
179compileJS JSTrue =
180 "true"
182compileJS JSFalse =
183 "false"
185compileJS (JSArray elems) =
186 "[" ++ intercalate "," (map compileJS elems) ++ "]"
188compileJS (JSString str) =
189 "\"" ++ str ++ "\""
191compileJS (JSNum num)
192 | JSInt i <- num = show i
193 | JSFloat f <- num = show f
194 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
195 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
196 | JSInteger (JSBigInt i) <- num = show i
197 | JSInteger (JSBigIntExpr e) <- num = "__IDRRT__bigInt(" ++ compileJS e ++ ")"
199compileJS (JSAssign lhs rhs) =
200 compileJS lhs ++ " = " ++ compileJS rhs
202compileJS (JSAlloc name val) =
203 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
205compileJS (JSIndex lhs rhs) =
206 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
208compileJS (JSCond branches) =
209 intercalate " else " $ map createIfBlock branches
210 where
211 createIfBlock (JSNoop, e) =
212 "{\n"
213 ++ compileJS e
214 ++ ";\n}"
215 createIfBlock (cond, e) =
216 "if (" ++ compileJS cond ++") {\n"
217 ++ compileJS e
218 ++ ";\n}"
220compileJS (JSSwitch val branches def) =
221 "switch(" ++ compileJS val ++ "){\n"
222 ++ concatMap mkBranch branches
223 ++ mkDefault def
224 ++ "}"
225 where
226 mkBranch :: (JS, JS) -> String
227 mkBranch (tag, code) =
228 "case " ++ compileJS tag ++ ":\n"
229 ++ compileJS code
230 ++ "\nbreak;\n"
232 mkDefault :: Maybe JS -> String
233 mkDefault Nothing = ""
234 mkDefault (Just def) =
235 "default:\n"
236 ++ compileJS def
237 ++ "\n"
240compileJS (JSTernary cond true false) =
241 let c = compileJS cond
242 t = compileJS true
243 f = compileJS false in
244 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
246compileJS (JSParens js) =
247 "(" ++ compileJS js ++ ")"
249compileJS (JSWhile cond body) =
250 "while (" ++ compileJS cond ++ ") {\n"
251 ++ compileJS body
252 ++ "\n}"
254compileJS (JSWord word)
255 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
256 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
257 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
258 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
260codegenJavaScript :: CodeGenerator
261codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
262 (includes ci) (outputFile ci) (outputType ci)
264codegenNode :: CodeGenerator
265codegenNode ci = codegenJS_all Node (simpleDecls ci)
266 (includes ci) (outputFile ci) (outputType ci)
268codegenJS_all
269 :: JSTarget
270 -> [(Name, SDecl)]
271 -> [FilePath]
272 -> FilePath
273 -> OutputType
274 -> IO ()
275codegenJS_all target definitions includes filename outputType = do
276 let code = map (compileJS . translateDecl . toBC) definitions
277 let (header, rt) = case target of
278 Node ->
279 ("#!/usr/bin/env node\n", "-node")
280 JavaScript ->
281 ("", "-browser")
282 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
283 idrRuntime <- readFile $ path ++ "Runtime-common.js"
284 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
285 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
286 let runtime = header ++ jsbn ++ idrRuntime ++ tgtRuntime
287 writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
288 setPermissions filename (emptyPermissions { readable = True
289 , executable = target == Node
290 , writable = True
291 })
292 where
293 main :: String
294 main = compileJS $
295 JSAlloc "main" $ Just $ JSFunction [] (
296 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
297 , JSApp (
298 JSIdent (translateName (sMN 0 "runMain"))
299 ) [ JSIdent "vm"
300 , JSNum (JSInt 0)
301 ]
302 ]
303 )
305 invokeMain :: String
306 invokeMain = compileJS $ JSApp (JSIdent "main") []
309translateDecl :: (Name, [BC]) -> JS
310translateDecl (name, bc) =
311 JSAlloc (
312 translateName name
313 ) (Just $ JSFunction ["vm", "oldbase"] (
314 JSSeq $ JSAlloc "myoldbase" Nothing : map translateBC bc)
315 )
317translateReg :: Reg -> JS
318translateReg reg
319 | RVal <- reg = JSProj (JSIdent "vm") "ret"
320 | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
321 | L 0 <- reg =
322 JSIndex (
323 JSProj (JSIdent "vm") "valstack"
324 ) (JSProj (JSIdent "vm") "valstack_base")
325 | L n <- reg =
326 JSIndex (
327 JSProj (JSIdent "vm") "valstack"
328 ) (
329 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
330 )
331 | T 0 <- reg =
332 JSIndex (
333 JSProj (JSIdent "vm") "valstack"
334 ) (JSProj (JSIdent "vm") "valstack_top")
335 | T n <- reg =
336 JSIndex (
337 JSProj (JSIdent "vm") "valstack"
338 ) (
339 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
340 )
342translateConstant :: Const -> JS
343translateConstant (I i) = JSNum (JSInt i)
344translateConstant (Fl f) = JSNum (JSFloat f)
345translateConstant (Ch c) = JSString $ translateChar c
346translateConstant (Str s) = JSString $ concatMap translateChar s
347translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
348translateConstant StrType = JSType JSStringTy
349translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
350translateConstant (AType ATFloat) = JSType JSFloatTy
351translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
352translateConstant PtrType = JSType JSPtrTy
353translateConstant Forgot = JSType JSForgotTy
354translateConstant (BI i) = jsBigInt (JSString $ show i)
355translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
356translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
357translateConstant (B8 b) = JSWord (JSWord8 b)
358translateConstant (B16 b) = JSWord (JSWord16 b)
359translateConstant (B32 b) = JSWord (JSWord32 b)
360translateConstant (B64 b) = JSWord (JSWord64 b)
361translateConstant c =
362 jsERROR $ "Unimplemented Constant: " ++ show c
365translateChar :: Char -> String
366translateChar ch
367 | '\a' <- ch = "\\u0007"
368 | '\b' <- ch = "\\b"
369 | '\f' <- ch = "\\f"
370 | '\n' <- ch = "\\n"
371 | '\r' <- ch = "\\r"
372 | '\t' <- ch = "\\t"
373 | '\v' <- ch = "\\v"
374 | '\SO' <- ch = "\\u000E"
375 | '\DEL' <- ch = "\\u007F"
376 | '\\' <- ch = "\\\\"
377 | '\"' <- ch = "\\\""
378 | '\'' <- ch = "\\\'"
379 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
380 | otherwise = [ch]
381 where
382 fill :: String -> String
383 fill s = if length s == 1
384 then '0' : s
385 else s
387 asciiTab =
388 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
389 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
390 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
391 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
393translateName :: Name -> String
394translateName n = "_idris_" ++ concatMap cchar (showCG n)
395 where cchar x | isAlpha x || isDigit x = [x]
396 | otherwise = "_" ++ show (fromEnum x) ++ "_"
398jsASSIGN :: Reg -> Reg -> JS
399jsASSIGN r1 r2 = JSAssign (translateReg r1) (translateReg r2)
401jsASSIGNCONST :: Reg -> Const -> JS
402jsASSIGNCONST r c = JSAssign (translateReg r) (translateConstant c)
404jsCALL :: Name -> JS
405jsCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
407jsTAILCALL :: Name -> JS
408jsTAILCALL n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
410jsFOREIGN :: Reg -> String -> [(FType, Reg)] -> JS
411jsFOREIGN reg n args =
412 JSAssign (
413 translateReg reg
414 ) (
415 JSApp (JSIdent n) (map (translateReg . snd) args)
416 )
418jsREBASE :: JS
419jsREBASE =
420 JSAssign (
421 JSProj (JSIdent "vm") "valstack_base"
422 ) (
423 JSIdent "oldbase"
424 )
426jsSTOREOLD :: JS
427jsSTOREOLD =
428 JSAssign (
429 JSIdent "myoldbase"
430 ) (
431 JSProj (JSIdent "vm") "valstack_base"
432 )
434jsADDTOP :: Int -> JS
435jsADDTOP n
436 | 0 <- n = JSNoop
437 | otherwise =
438 JSBinOp "+=" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
440jsTOPBASE :: Int -> JS
441jsTOPBASE n
442 | 0 <- n =
443 JSAssign (
444 JSProj (JSIdent "vm") "valstack_top"
445 ) (
446 JSProj (JSIdent "vm") "valstack_base"
447 )
448 | otherwise =
449 JSAssign (
450 JSProj (JSIdent "vm") "valstack_top"
451 ) (
452 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_base") (JSNum (JSInt n))
453 )
455jsBASETOP :: Int -> JS
456jsBASETOP n
457 | 0 <- n =
458 JSAssign (
459 JSProj (JSIdent "vm") "valstack_base"
460 ) (
461 JSProj (JSIdent "vm") "valstack_top"
462 )
463 | otherwise =
464 JSAssign (
465 JSProj (JSIdent "vm") "valstack_base"
466 ) (
467 JSBinOp "+" (JSProj (JSIdent "vm") "valstack_top") (JSNum (JSInt n))
468 )
470jsNULL :: Reg -> JS
471jsNULL r = JSAssign (translateReg r) JSNull
473jsERROR :: String -> JS
474jsERROR = JSError
476jsSLIDE :: Int -> JS
477jsSLIDE n = JSApp (JSIdent "i$SLIDE") [JSIdent "vm", JSNum (JSInt n)]
479jsMKCON :: Reg -> Int -> [Reg] -> JS
480jsMKCON r t rs =
481 JSAssign (translateReg r) (
482 JSNew "i$CON" [JSNum (JSInt t), JSArray (map translateReg rs)]
483 )
485jsInstanceOf :: JS -> String -> JS
486jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
488jsOr :: JS -> JS -> JS
489jsOr lhs rhs = JSBinOp "||" lhs rhs
491jsTypeOf :: JS -> JS
492jsTypeOf js = JSPreOp "typeof " js
494jsEq :: JS -> JS -> JS
495jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
496jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
497jsEq lhs rhs = JSBinOp "==" lhs rhs
499jsIsNumber :: JS -> JS
500jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
502jsIsNull :: JS -> JS
503jsIsNull js = JSBinOp "==" js JSNull
505jsBigInt :: JS -> JS
506jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
507jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
508jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
510jsUnPackBits :: JS -> JS
511jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
513jsPackUBits8 :: JS -> JS
514jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
516jsPackUBits16 :: JS -> JS
517jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
519jsPackUBits32 :: JS -> JS
520jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
522jsPackSBits8 :: JS -> JS
523jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
525jsPackSBits16 :: JS -> JS
526jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
528jsPackSBits32 :: JS -> JS
529jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
531jsCASE :: Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
532jsCASE safe reg cases def =
533 JSSwitch (tag safe $ translateReg reg) (
534 map ((JSNum . JSInt) *** prepBranch) cases
535 ) (fmap prepBranch def)
536 where
537 tag :: Bool -> JS -> JS
538 tag True = jsCTAG
539 tag False = jsTAG
541 prepBranch :: [BC] -> JS
542 prepBranch bc = JSSeq $ map translateBC bc
544 jsTAG :: JS -> JS
545 jsTAG js =
546 JSTernary (jsIsNumber js `jsOr` jsIsNull js) (
547 JSNum (JSInt $ negate 1)
548 ) (JSTernary (js `jsInstanceOf` "i$CON") (
549 JSProj js "tag"
550 ) (JSNum (JSInt $ negate 1)))
552 jsCTAG :: JS -> JS
553 jsCTAG js = JSProj js "tag"
556jsCONSTCASE :: Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
557jsCONSTCASE reg cases def =
558 JSCond $ (
559 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
560 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
561 where
562 prepBranch :: [BC] -> JS
563 prepBranch bc = JSSeq $ map translateBC bc
565jsPROJECT :: Reg -> Int -> Int -> JS
566jsPROJECT reg loc ar =
567 JSApp (JSIdent "i$PROJECT") [ JSIdent "vm"
568 , translateReg reg
569 , JSNum (JSInt loc)
570 , JSNum (JSInt ar)
571 ]
573jsOP :: Reg -> PrimFn -> [Reg] -> JS
574jsOP reg op args = JSAssign (translateReg reg) jsOP'
575 where
576 jsOP' :: JS
577 jsOP'
578 | LNoOp <- op = translateReg (last args)
580 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
581 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
582 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
584 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
585 | (LPlus (ATInt ITBig)) <- op
586 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
587 | (LMinus (ATInt ITBig)) <- op
588 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
589 | (LTimes (ATInt ITBig)) <- op
590 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
591 | (LSDiv (ATInt ITBig)) <- op
592 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
593 | (LSRem (ATInt ITBig)) <- op
594 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
595 | (LEq (ATInt ITBig)) <- op
596 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
597 | (LSLt (ATInt ITBig)) <- op
598 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
599 | (LSLe (ATInt ITBig)) <- op
600 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
601 | (LSGt (ATInt ITBig)) <- op
602 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
603 | (LSGe (ATInt ITBig)) <- op
604 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
606 | (LPlus ATFloat) <- op
607 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
608 | (LMinus ATFloat) <- op
609 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
610 | (LTimes ATFloat) <- op
611 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
612 | (LSDiv ATFloat) <- op
613 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
614 | (LEq ATFloat) <- op
615 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
616 | (LSLt ATFloat) <- op
617 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
618 | (LSLe ATFloat) <- op
619 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
620 | (LSGt ATFloat) <- op
621 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
622 | (LSGe ATFloat) <- op
623 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
625 | (LPlus (ATInt ITChar)) <- op
626 , (lhs:rhs:_) <- args =
627 jsCall "__IDRRT__fromCharCode" [
628 JSBinOp "+" (
629 jsCall "__IDRRT__charCode" [translateReg lhs]
630 ) (
631 jsCall "__IDRRT__charCode" [translateReg rhs]
632 )
633 ]
635 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
636 , (arg:_) <- args =
637 jsPackUBits8 (
638 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
639 )
641 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
642 , (arg:_) <- args =
643 jsPackUBits16 (
644 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
645 )
647 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
648 , (arg:_) <- args =
649 jsPackUBits32 (
650 jsMeth (jsMeth (translateReg arg) "and" [
651 jsBigInt (JSString $ show 0xFFFFFFFF)
652 ]) "intValue" []
653 )
655 | (LTrunc ITBig (ITFixed IT64)) <- op
656 , (arg:_) <- args =
657 jsMeth (translateReg arg) "and" [
658 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
659 ]
661 | (LLSHR (ITFixed IT8)) <- op
662 , (lhs:rhs:_) <- args =
663 jsPackUBits8 (
664 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
665 )
667 | (LLSHR (ITFixed IT16)) <- op
668 , (lhs:rhs:_) <- args =
669 jsPackUBits16 (
670 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
671 )
673 | (LLSHR (ITFixed IT32)) <- op
674 , (lhs:rhs:_) <- args =
675 jsPackUBits32 (
676 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
677 )
679 | (LLSHR (ITFixed IT64)) <- op
680 , (lhs:rhs:_) <- args =
681 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
683 | (LSHL (ITFixed IT8)) <- op
684 , (lhs:rhs:_) <- args =
685 jsPackUBits8 (
686 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
687 )
689 | (LSHL (ITFixed IT16)) <- op
690 , (lhs:rhs:_) <- args =
691 jsPackUBits16 (
692 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
693 )
695 | (LSHL (ITFixed IT32)) <- op
696 , (lhs:rhs:_) <- args =
697 jsPackUBits32 (
698 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
699 )
701 | (LSHL (ITFixed IT64)) <- op
702 , (lhs:rhs:_) <- args =
703 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
704 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
705 ]
707 | (LAnd (ITFixed IT8)) <- op
708 , (lhs:rhs:_) <- args =
709 jsPackUBits8 (
710 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
711 )
713 | (LAnd (ITFixed IT16)) <- op
714 , (lhs:rhs:_) <- args =
715 jsPackUBits16 (
716 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
717 )
719 | (LAnd (ITFixed IT32)) <- op
720 , (lhs:rhs:_) <- args =
721 jsPackUBits32 (
722 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
723 )
725 | (LAnd (ITFixed IT64)) <- op
726 , (lhs:rhs:_) <- args =
727 jsMeth (translateReg lhs) "and" [translateReg rhs]
729 | (LOr (ITFixed IT8)) <- op
730 , (lhs:rhs:_) <- args =
731 jsPackUBits8 (
732 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
733 )
735 | (LOr (ITFixed IT16)) <- op
736 , (lhs:rhs:_) <- args =
737 jsPackUBits16 (
738 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
739 )
741 | (LOr (ITFixed IT32)) <- op
742 , (lhs:rhs:_) <- args =
743 jsPackUBits32 (
744 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
745 )
747 | (LOr (ITFixed IT64)) <- op
748 , (lhs:rhs:_) <- args =
749 jsMeth (translateReg lhs) "or" [translateReg rhs]
751 | (LXOr (ITFixed IT8)) <- op
752 , (lhs:rhs:_) <- args =
753 jsPackUBits8 (
754 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
755 )
757 | (LXOr (ITFixed IT16)) <- op
758 , (lhs:rhs:_) <- args =
759 jsPackUBits16 (
760 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
761 )
763 | (LXOr (ITFixed IT32)) <- op
764 , (lhs:rhs:_) <- args =
765 jsPackUBits32 (
766 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
767 )
769 | (LXOr (ITFixed IT64)) <- op
770 , (lhs:rhs:_) <- args =
771 jsMeth (translateReg lhs) "xor" [translateReg rhs]
773 | (LPlus (ATInt (ITFixed IT8))) <- op
774 , (lhs:rhs:_) <- args =
775 jsPackUBits8 (
776 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
777 )
779 | (LPlus (ATInt (ITFixed IT16))) <- op
780 , (lhs:rhs:_) <- args =
781 jsPackUBits16 (
782 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
783 )
785 | (LPlus (ATInt (ITFixed IT32))) <- op
786 , (lhs:rhs:_) <- args =
787 jsPackUBits32 (
788 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
789 )
791 | (LPlus (ATInt (ITFixed IT64))) <- op
792 , (lhs:rhs:_) <- args =
793 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
794 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
795 ]
797 | (LMinus (ATInt (ITFixed IT8))) <- op
798 , (lhs:rhs:_) <- args =
799 jsPackUBits8 (
800 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
801 )
803 | (LMinus (ATInt (ITFixed IT16))) <- op
804 , (lhs:rhs:_) <- args =
805 jsPackUBits16 (
806 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
807 )
809 | (LMinus (ATInt (ITFixed IT32))) <- op
810 , (lhs:rhs:_) <- args =
811 jsPackUBits32 (
812 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
813 )
815 | (LMinus (ATInt (ITFixed IT64))) <- op
816 , (lhs:rhs:_) <- args =
817 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
818 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
819 ]
821 | (LTimes (ATInt (ITFixed IT8))) <- op
822 , (lhs:rhs:_) <- args =
823 jsPackUBits8 (
824 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
825 )
827 | (LTimes (ATInt (ITFixed IT16))) <- op
828 , (lhs:rhs:_) <- args =
829 jsPackUBits16 (
830 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
831 )
833 | (LTimes (ATInt (ITFixed IT32))) <- op
834 , (lhs:rhs:_) <- args =
835 jsPackUBits32 (
836 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
837 )
839 | (LTimes (ATInt (ITFixed IT64))) <- op
840 , (lhs:rhs:_) <- args =
841 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
842 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
843 ]
845 | (LEq (ATInt (ITFixed IT8))) <- op
846 , (lhs:rhs:_) <- args =
847 jsPackUBits8 (
848 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
849 )
851 | (LEq (ATInt (ITFixed IT16))) <- op
852 , (lhs:rhs:_) <- args =
853 jsPackUBits16 (
854 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
855 )
857 | (LEq (ATInt (ITFixed IT32))) <- op
858 , (lhs:rhs:_) <- args =
859 jsPackUBits32 (
860 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
861 )
863 | (LEq (ATInt (ITFixed IT64))) <- op
864 , (lhs:rhs:_) <- args =
865 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
866 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
867 ]
869 | (LLt (ITFixed IT8)) <- op
870 , (lhs:rhs:_) <- args =
871 jsPackUBits8 (
872 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
873 )
875 | (LLt (ITFixed IT16)) <- op
876 , (lhs:rhs:_) <- args =
877 jsPackUBits16 (
878 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
879 )
881 | (LLt (ITFixed IT32)) <- op
882 , (lhs:rhs:_) <- args =
883 jsPackUBits32 (
884 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
885 )
887 | (LLt (ITFixed IT64)) <- op
888 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
890 | (LLe (ITFixed IT8)) <- op
891 , (lhs:rhs:_) <- args =
892 jsPackUBits8 (
893 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
894 )
896 | (LLe (ITFixed IT16)) <- op
897 , (lhs:rhs:_) <- args =
898 jsPackUBits16 (
899 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
900 )
902 | (LLe (ITFixed IT32)) <- op
903 , (lhs:rhs:_) <- args =
904 jsPackUBits32 (
905 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
906 )
908 | (LLe (ITFixed IT64)) <- op
909 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
911 | (LGt (ITFixed IT8)) <- op
912 , (lhs:rhs:_) <- args =
913 jsPackUBits8 (
914 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
915 )
917 | (LGt (ITFixed IT16)) <- op
918 , (lhs:rhs:_) <- args =
919 jsPackUBits16 (
920 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
921 )
922 | (LGt (ITFixed IT32)) <- op
923 , (lhs:rhs:_) <- args =
924 jsPackUBits32 (
925 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
926 )
928 | (LGt (ITFixed IT64)) <- op
929 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
931 | (LGe (ITFixed IT8)) <- op
932 , (lhs:rhs:_) <- args =
933 jsPackUBits8 (
934 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
935 )
937 | (LGe (ITFixed IT16)) <- op
938 , (lhs:rhs:_) <- args =
939 jsPackUBits16 (
940 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
941 )
942 | (LGe (ITFixed IT32)) <- op
943 , (lhs:rhs:_) <- args =
944 jsPackUBits32 (
945 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
946 )
948 | (LGe (ITFixed IT64)) <- op
949 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
951 | (LUDiv (ITFixed IT8)) <- op
952 , (lhs:rhs:_) <- args =
953 jsPackUBits8 (
954 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
955 )
957 | (LUDiv (ITFixed IT16)) <- op
958 , (lhs:rhs:_) <- args =
959 jsPackUBits16 (
960 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
961 )
963 | (LUDiv (ITFixed IT32)) <- op
964 , (lhs:rhs:_) <- args =
965 jsPackUBits32 (
966 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
967 )
969 | (LUDiv (ITFixed IT64)) <- op
970 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
972 | (LSDiv (ATInt (ITFixed IT8))) <- op
973 , (lhs:rhs:_) <- args =
974 jsPackSBits8 (
975 JSBinOp "/" (
976 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
977 ) (
978 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
979 )
980 )
982 | (LSDiv (ATInt (ITFixed IT16))) <- op
983 , (lhs:rhs:_) <- args =
984 jsPackSBits16 (
985 JSBinOp "/" (
986 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
987 ) (
988 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
989 )
990 )
992 | (LSDiv (ATInt (ITFixed IT32))) <- op
993 , (lhs:rhs:_) <- args =
994 jsPackSBits32 (
995 JSBinOp "/" (
996 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
997 ) (
998 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
999 )
1002 | (LSDiv (ATInt (ITFixed IT64))) <- op
1003 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1005 | (LSRem (ATInt (ITFixed IT8))) <- op
1006 , (lhs:rhs:_) <- args =
1007 jsPackSBits8 (
1008 JSBinOp "%" (
1009 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1010 ) (
1011 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1015 | (LSRem (ATInt (ITFixed IT16))) <- op
1016 , (lhs:rhs:_) <- args =
1017 jsPackSBits16 (
1018 JSBinOp "%" (
1019 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1020 ) (
1021 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1025 | (LSRem (ATInt (ITFixed IT32))) <- op
1026 , (lhs:rhs:_) <- args =
1027 jsPackSBits32 (
1028 JSBinOp "%" (
1029 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1030 ) (
1031 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1035 | (LSRem (ATInt (ITFixed IT64))) <- op
1036 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1038 | (LCompl (ITFixed IT8)) <- op
1039 , (arg:_) <- args =
1040 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1042 | (LCompl (ITFixed IT16)) <- op
1043 , (arg:_) <- args =
1044 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1046 | (LCompl (ITFixed IT32)) <- op
1047 , (arg:_) <- args =
1048 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1050 | (LCompl (ITFixed IT64)) <- op
1051 , (arg:_) <- args =
1052 invokeMeth arg "not" []
1054 | (LPlus _) <- op
1055 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1056 | (LMinus _) <- op
1057 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1058 | (LTimes _) <- op
1059 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1060 | (LSDiv _) <- op
1061 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1062 | (LSRem _) <- op
1063 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1064 | (LEq _) <- op
1065 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1066 | (LSLt _) <- op
1067 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1068 | (LSLe _) <- op
1069 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1070 | (LSGt _) <- op
1071 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1072 | (LSGe _) <- op
1073 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1074 | (LAnd _) <- op
1075 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1076 | (LOr _) <- op
1077 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1078 | (LXOr _) <- op
1079 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1080 | (LSHL _) <- op
1081 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1082 | (LASHR _) <- op
1083 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1084 | (LCompl _) <- op
1085 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1087 | LStrConcat <- op
1088 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1089 | LStrEq <- op
1090 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1091 | LStrLt <- op
1092 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1093 | LStrLen <- op
1094 , (arg:_) <- args = JSProj (translateReg arg) "length"
1095 | (LStrInt ITNative) <- op
1096 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1097 | (LIntStr ITNative) <- op
1098 , (arg:_) <- args = jsCall "String" [translateReg arg]
1099 | (LSExt ITNative ITBig) <- op
1100 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1101 | (LTrunc ITBig ITNative) <- op
1102 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1103 | (LIntStr ITBig) <- op
1104 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1105 | (LStrInt ITBig) <- op
1106 , (arg:_) <- args = jsBigInt $ translateReg arg
1107 | LFloatStr <- op
1108 , (arg:_) <- args = jsCall "String" [translateReg arg]
1109 | LStrFloat <- op
1110 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1111 | (LIntFloat ITNative) <- op
1112 , (arg:_) <- args = translateReg arg
1113 | (LFloatInt ITNative) <- op
1114 , (arg:_) <- args = translateReg arg
1115 | (LChInt ITNative) <- op
1116 , (arg:_) <- args = jsCall "__IDRRT__charCode" [translateReg arg]
1117 | (LIntCh ITNative) <- op
1118 , (arg:_) <- args = jsCall "__IDRRT__fromCharCode" [translateReg arg]
1120 | LFExp <- op
1121 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1122 | LFLog <- op
1123 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1124 | LFSin <- op
1125 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1126 | LFCos <- op
1127 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1128 | LFTan <- op
1129 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1130 | LFASin <- op
1131 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1132 | LFACos <- op
1133 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1134 | LFATan <- op
1135 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1136 | LFSqrt <- op
1137 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1138 | LFFloor <- op
1139 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1140 | LFCeil <- op
1141 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1143 | LStrCons <- op
1144 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1145 | LStrHead <- op
1146 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1147 | LStrRev <- op
1148 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1149 | LStrIndex <- op
1150 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1151 | LStrTail <- op
1152 , (arg:_) <- args =
1153 let v = translateReg arg in
1154 JSApp (JSProj v "substr") [
1155 JSNum (JSInt 1),
1156 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1159 | LSystemInfo <- op
1160 , (arg:_) <- args = jsCall "__IDRRT__systemInfo" [translateReg arg]
1161 | LNullPtr <- op
1162 , (_) <- args = JSNull
1163 | otherwise = JSError $ "Not implemented: " ++ show op
1164 where
1165 translateBinaryOp :: String -> Reg -> Reg -> JS
1166 translateBinaryOp op lhs rhs =
1167 JSBinOp op (translateReg lhs) (translateReg rhs)
1169 invokeMeth :: Reg -> String -> [Reg] -> JS
1170 invokeMeth obj meth args =
1171 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1173 jsMeth :: JS -> String -> [JS] -> JS
1174 jsMeth obj meth args = JSApp (JSProj obj meth) args
1177 jsCall :: String -> [JS] -> JS
1178 jsCall fun args = JSApp (JSIdent fun) args
1180jsRESERVE :: Int -> JS
1181jsRESERVE n = JSApp (JSIdent "i$RESERVE") [JSIdent "vm", JSNum $ JSInt n]
1183translateBC :: BC -> JS
1184translateBC bc
1185 | ASSIGN r1 r2 <- bc = jsASSIGN r1 r2
1186 | ASSIGNCONST r c <- bc = jsASSIGNCONST r c
1187 | UPDATE r1 r2 <- bc = jsASSIGN r1 r2
1188 | ADDTOP n <- bc = jsADDTOP n
1189 | NULL r <- bc = jsNULL r
1190 | CALL n <- bc = jsCALL n
1191 | TAILCALL n <- bc = jsTAILCALL n
1192 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN r n a
1193 | TOPBASE n <- bc = jsTOPBASE n
1194 | BASETOP n <- bc = jsBASETOP n
1195 | STOREOLD <- bc = jsSTOREOLD
1196 | SLIDE n <- bc = jsSLIDE n
1197 | REBASE <- bc = jsREBASE
1198 | RESERVE n <- bc = jsRESERVE n
1199 | MKCON r t rs <- bc = jsMKCON r t rs
1200 | CASE s r c d <- bc = jsCASE s r c d
1201 | CONSTCASE r c d <- bc = jsCONSTCASE r c d
1202 | PROJECT r l a <- bc = jsPROJECT r l a
1203 | OP r o a <- bc = jsOP r o a
1204 | ERROR e <- bc = jsERROR e
1205 | otherwise = JSRaw $ show bc
1206 {-| PROJECTINTO _ _ _ <- bc = undefined-}