@@ -14,12 +14,14 @@ import Util.System
1414import Control.Arrow
1515import Data.Char
1616import Data.List
17+import Data.Maybe
1718import System.IO
1819import System.Directory
1920
2021idrNamespace :: String
2122idrNamespace = "__IDR__"
2223idrRTNamespace = "__IDRRT__"
24+idrLTNamespace = "__IDRLT__"
2325
2426data JSTarget = Node | JavaScript deriving Eq
2527
@@ -58,6 +60,7 @@ data JS = JSRaw String
5860 | JSAlloc String (Maybe JS)
5961 | JSIndex JS JS
6062 | JSCond [(JS, JS)]
63+ | JSTernary JS JS JS
6164
6265compileJS :: JS -> String
6366compileJS (JSRaw code) =
@@ -154,6 +157,12 @@ compileJS (JSCond branches) =
154157 ++ "return " ++ compileJS e
155158 ++ ";\n}"
156159
160+compileJS (JSTernary cond true false) =
161+ let c = compileJS cond
162+ t = compileJS true
163+ f = compileJS false in
164+ "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
165+
157166jsTailcall :: JS -> JS
158167jsTailcall call =
159168 jsCall (idrRTNamespace ++ "tailcall") [
@@ -183,10 +192,10 @@ jsCon :: JS
183192jsCon = JSRaw $ idrRTNamespace ++ "Con"
184193
185194jsTag :: JS -> JS
186−jsTag obj = (JSProj obj "tag")
195+jsTag obj = JSProj obj "tag"
187196
188197jsTypeTag :: JS -> JS
189−jsTypeTag obj = (JSProj obj "type")
198+jsTypeTag obj = JSProj obj "type"
190199
191200jsBigInt :: JS -> JS
192201jsBigInt val =
@@ -195,6 +204,14 @@ jsBigInt val =
195204jsVar :: Int -> String
196205jsVar = ("__var_" ++) . show
197206
207+jsLet :: String -> JS -> JS -> JS
208+jsLet name value body =
209+ JSApp (
210+ JSFunction [name] (
211+ JSReturn body
212+ )
213+ ) [value]
214+
198215codegenJavaScript
199216 :: JSTarget
200217 -> [(Name, SDecl)]
@@ -319,31 +336,98 @@ translateConstant c =
319336 JSError $ "Unimplemented Constant: " ++ show c
320337
321338translateDeclaration :: (String, SDecl) -> JS
322−translateDeclaration (path, SFun name params stackSize body) =
323− JSAlloc (path ++ translateName name) $ Just $ JSFunction p (
324− JSSeq $
325− zipWith assignVar [0..] p ++
326− map allocVar [numP .. (numP + stackSize - 1)] ++
327− [JSReturn $ translateExpression body]
328− )
339+translateDeclaration (path, SFun name params stackSize body)
340+ | (MN _ "APPLY") <- name
341+ , (SLet var val next) <- body
342+ , (SChkCase cvar cases) <- next =
343+ let lvar = translateVariableName var
344+ lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
345+ JSSeq [ lookupTable [(var, "chk")] var cases
346+ , jsDecl $ JSFunction ["fn0", "arg0"] (
347+ JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
348+ , JSReturn $ jsLet (translateVariableName var) (
349+ translateExpression val
350+ ) (JSTernary (
351+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`
352+ (hasProp lookupTableName (translateVariableName var))
353+ ) (JSRaw $
354+ lookupTableName ++ lookup
355+ ) JSNull
356+ )
357+ ]
358+ )
359+ ]
360+
361+ | (MN _ "EVAL") <- name
362+ , (SChkCase var cases) <- body =
363+ JSSeq [ lookupTable [] var cases
364+ , jsDecl $ JSFunction ["arg0"] (JSReturn $
365+ JSTernary (
366+ (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
367+ (hasProp lookupTableName "arg0")
368+ ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
369+ )
370+ ]
371+ | otherwise =
372+ let fun = translateExpression body in
373+ jsDecl $ jsFun fun
374+
329375 where
330− numP :: Int
331− numP = length params
376+ hasProp :: String -> String -> JS
377+ hasProp table var =
378+ jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
379+
380+ caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
381+ caseFun aux var cse =
382+ jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
332383
333− allocVar :: Int -> JS
334− allocVar n = JSAlloc (jsVar n) Nothing
384+ getTag :: SAlt -> Maybe String
385+ getTag (SConCase _ tag _ _ _) = Just $ show tag
386+ getTag _ = Nothing
335387
336− assignVar :: Int -> String -> JS
337− assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
388+ lookupTableName :: String
389+ lookupTableName = idrLTNamespace ++ translateName name
338390
339− p :: [String]
340− p = map translateParameter params
391+ lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
392+ lookupTable aux var cases =
393+ JSAlloc lookupTableName $ Just (
394+ JSObject $ catMaybes $ map (lookupEntry aux var) cases
395+ )
341396 where
342− translateParameter :: Name -> String
343− translateParameter (MN i name) =
344− translateIdentifier name ++ show i
345− translateParameter (UN name) =
346− translateIdentifier name
397+ lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
398+ lookupEntry aux var alt = do
399+ tag <- getTag alt
400+ return (tag, caseFun aux var alt)
401+
402+ jsDecl :: JS -> JS
403+ jsDecl = JSAlloc (path ++ translateName name) . Just
404+
405+ jsFun body = jsFunAux [] body
406+
407+ jsFunAux :: [(LVar, String)] -> JS -> JS
408+ jsFunAux aux body =
409+ JSFunction (p ++ map snd aux) (
410+ JSSeq $
411+ zipWith assignVar [0..] p ++
412+ map allocVar [numP .. (numP + stackSize - 1)] ++
413+ map assignAux aux ++
414+ [JSReturn body]
415+ )
416+ where
417+ numP :: Int
418+ numP = length params
419+
420+ allocVar :: Int -> JS
421+ allocVar n = JSAlloc (jsVar n) Nothing
422+
423+ assignVar :: Int -> String -> JS
424+ assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
425+
426+ assignAux :: (LVar, String) -> JS
427+ assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
428+
429+ p :: [String]
430+ p = map translateName params
347431
348432translateVariableName :: LVar -> String
349433translateVariableName (Loc i) =
@@ -351,11 +435,9 @@ translateVariableName (Loc i) =
351435
352436translateExpression :: SExp -> JS
353437translateExpression (SLet name value body) =
354− JSApp (
355− JSFunction [translateVariableName name] (
356− JSReturn $ translateExpression body
357− )
358− ) [translateExpression value]
438+ jsLet (translateVariableName name) (
439+ translateExpression value
440+ ) (translateExpression body)
359441
360442translateExpression (SConst cst) =
361443 translateConstant cst
@@ -377,46 +459,46 @@ translateExpression (SApp tc name vars)
377459translateExpression (SOp op vars)
378460 | LNoOp <- op = JSVar (last vars)
379461
380− | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
381− | (LPlus (ATInt ITBig)) <- op
382− , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
462+ | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
463+ | (LPlus (ATInt ITBig)) <- op
464+ , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
383465 | (LMinus (ATInt ITBig)) <- op
384− , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
466+ , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
385467 | (LTimes (ATInt ITBig)) <- op
386− , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
387− | (LSDiv (ATInt ITBig)) <- op
388− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
389− | (LSRem (ATInt ITBig)) <- op
390− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
391− | (LEq (ATInt ITBig)) <- op
392− , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
393− | (LSLt (ATInt ITBig)) <- op
394− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
395− | (LSLe (ATInt ITBig)) <- op
396− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
397− | (LSGt (ATInt ITBig)) <- op
398− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
399− | (LSGe (ATInt ITBig)) <- op
400− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
468+ , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
469+ | (LSDiv (ATInt ITBig)) <- op
470+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
471+ | (LSRem (ATInt ITBig)) <- op
472+ , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
473+ | (LEq (ATInt ITBig)) <- op
474+ , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
475+ | (LSLt (ATInt ITBig)) <- op
476+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
477+ | (LSLe (ATInt ITBig)) <- op
478+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
479+ | (LSGt (ATInt ITBig)) <- op
480+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
481+ | (LSGe (ATInt ITBig)) <- op
482+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
401483
402484 | (LPlus ATFloat) <- op
403− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
485+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
404486 | (LMinus ATFloat) <- op
405− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
487+ , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
406488 | (LTimes ATFloat) <- op
407− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
489+ , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
408490 | (LSDiv ATFloat) <- op
409− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
410− | (LEq ATFloat) <- op
411− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
412− | (LSLt ATFloat) <- op
413− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
414− | (LSLe ATFloat) <- op
415− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
416− | (LSGt ATFloat) <- op
417− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
418− | (LSGe ATFloat) <- op
419− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
491+ , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
492+ | (LEq ATFloat) <- op
493+ , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
494+ | (LSLt ATFloat) <- op
495+ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
496+ | (LSLe ATFloat) <- op
497+ , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
498+ | (LSGt ATFloat) <- op
499+ , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
500+ | (LSGe ATFloat) <- op
501+ , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
420502
421503 | (LPlus _) <- op
422504 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -430,13 +512,13 @@ translateExpression (SOp op vars)
430512 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
431513 | (LEq _) <- op
432514 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
433− | (LSLt _) <- op
515+ | (LSLt _) <- op
434516 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
435− | (LSLe _) <- op
517+ | (LSLe _) <- op
436518 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
437− | (LSGt _) <- op
519+ | (LSGt _) <- op
438520 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
439− | (LSGe _) <- op
521+ | (LSGe _) <- op
440522 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
441523 | (LAnd _) <- op
442524 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
@@ -460,30 +542,30 @@ translateExpression (SOp op vars)
460542 | LStrLen <- op
461543 , (arg:_) <- vars = JSProj (JSVar arg) "length"
462544
463− | (LStrInt ITNative) <- op
464− , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
465− | (LIntStr ITNative) <- op
466− , (arg:_) <- vars = jsCall "String" [JSVar arg]
467− | (LSExt ITNative ITBig) <- op
468− , (arg:_) <- vars = jsBigInt $ JSVar arg
545+ | (LStrInt ITNative) <- op
546+ , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
547+ | (LIntStr ITNative) <- op
548+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
549+ | (LSExt ITNative ITBig) <- op
550+ , (arg:_) <- vars = jsBigInt $ JSVar arg
469551 | (LTrunc ITBig ITNative) <- op
470− , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
471− | (LIntStr ITBig) <- op
472− , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
473− | (LStrInt ITBig) <- op
474− , (arg:_) <- vars = jsBigInt $ JSVar arg
475− | LFloatStr <- op
476− , (arg:_) <- vars = jsCall "String" [JSVar arg]
477− | LStrFloat <- op
478− , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
479− | (LIntFloat ITNative) <- op
480− , (arg:_) <- vars = JSVar arg
481− | (LFloatInt ITNative) <- op
482− , (arg:_) <- vars = JSVar arg
483− | (LChInt ITNative) <- op
484− , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
485− | (LIntCh ITNative) <- op
486− , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
552+ , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
553+ | (LIntStr ITBig) <- op
554+ , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
555+ | (LStrInt ITBig) <- op
556+ , (arg:_) <- vars = jsBigInt $ JSVar arg
557+ | LFloatStr <- op
558+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
559+ | LStrFloat <- op
560+ , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
561+ | (LIntFloat ITNative) <- op
562+ , (arg:_) <- vars = JSVar arg
563+ | (LFloatInt ITNative) <- op
564+ , (arg:_) <- vars = JSVar arg
565+ | (LChInt ITNative) <- op
566+ , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
567+ | (LIntCh ITNative) <- op
568+ , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
487569
488570 | LFExp <- op
489571 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
@@ -600,7 +682,7 @@ translateExpression patterncase
600682 where
601683 caseHelper var cases param =
602684 JSApp (JSFunction [param] (
603− JSCond $ map ((expandCase param) . translateCase param) cases
685+ JSCond $ map (expandCase param . translateCaseCond param) cases
604686 )) [JSVar var]
605687
606688 expandCase :: String -> (Cond, JS) -> (JS, JS)
@@ -641,11 +723,11 @@ data CaseType = ConCase Int
641723data Cond = CaseCond CaseType
642724 | RawCond JS
643725
644−translateCase :: String -> SAlt -> (Cond, JS)
645−translateCase _ (SDefaultCase e) =
646− (CaseCond DefaultCase, translateExpression e)
726+translateCaseCond :: String -> SAlt -> (Cond, JS)
727+translateCaseCond _ cse@(SDefaultCase _) =
728+ (CaseCond DefaultCase, translateCase Nothing cse)
647729
648−translateCase var (SConstCase ty e)
730+translateCaseCond var cse@(SConstCase ty _)
649731 | StrType <- ty = matchHelper JSStringTy
650732 | PtrType <- ty = matchHelper JSPtrTy
651733 | Forgot <- ty = matchHelper JSForgotTy
@@ -655,20 +737,24 @@ translateCase var (SConstCase ty e)
655737 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
656738 where
657739 matchHelper :: JSType -> (Cond, JS)
658− matchHelper ty = (CaseCond $ TypeCase ty, translateExpression e)
740+ matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
659741
660−translateCase var (SConstCase cst@(BI _) e) =
742+translateCaseCond var cse@(SConstCase cst@(BI _) _) =
661743 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
662− (RawCond cond, translateExpression e)
744+ (RawCond cond, translateCase Nothing cse)
663745
664−translateCase var (SConstCase cst e) =
746+translateCaseCond var cse@(SConstCase cst _) =
665747 let cond = JSRaw var `jsEq` translateConstant cst in
666− (RawCond cond, translateExpression e)
748+ (RawCond cond, translateCase Nothing cse)
667749
668−translateCase var (SConCase a tag name vars e) =
750+translateCaseCond var cse@(SConCase _ tag _ _ _) =
751+ (CaseCond $ ConCase tag, translateCase (Just var) cse)
752+
753+translateCase :: Maybe String -> SAlt -> JS
754+translateCase _ (SDefaultCase e) = translateExpression e
755+translateCase _ (SConstCase _ e) = translateExpression e
756+translateCase (Just var) (SConCase a _ _ vars e) =
669757 let params = map jsVar [a .. (a + length vars)] in
670− (CaseCond $ ConCase tag,
671− jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
672− JSThis, JSProj (JSRaw var) "vars"
673− ]
674− )
758+ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
759+ JSThis, JSProj (JSRaw var) "vars"
760+ ]