on master help sign in
javascript: hardwired apply lookuptable
commit10d4cd6ca5c1b80379af2b4d3f4a39e0382a5bc0 authorraichoo <raichoo@googlemail.com> dateFri 23 Aug 2013, 22:45 (13 years ago) parentfeafcea
1 file changed+21−16
src/IRTS/CodegenJavaScript.hs+21−16
src/IRTS/CodegenJavaScript.hs+21−16
@@ -334,11 +334,10 @@ translateDeclaration (path, SFun name params stackSize body)
334334 , (SLet var val next) <- body
335335 , (SChkCase cvar cases) <- next =
336336 let fun = translateExpression body in
337− {-jsDecl $ jsFun fun-}
338− JSSeq [ lookupTable Nothing var cases
337+ JSSeq [ lookupTable [(var, "chk")] var cases
339338 , jsDecl $ JSFunction ["fn0", "arg0"] (
340339 JSSeq [ JSRaw "var __var_0 = fn0"
341− , jsLet (translateVariableName var) (
340+ , JSReturn $ jsLet (translateVariableName var) (
342341 translateExpression val
343342 ) (JSRaw $
344343 concat [ "(" ++ translateVariableName var ++ " instanceof __IDRRT__Con "
@@ -352,7 +351,7 @@ translateDeclaration (path, SFun name params stackSize body)
352351
353352 | (MN _ "EVAL") <- name
354353 , (SChkCase var cases) <- body =
355− JSSeq [ lookupTable Nothing var cases
354+ JSSeq [ lookupTable [] var cases
356355 , jsDecl $ JSFunction ["arg0"] (JSRaw $
357356 concat [ "if (arg0 instanceof __IDRRT__Con "
358357 , " && " ++ lookupTableName ++ ".hasOwnProperty(arg0.tag))"
@@ -367,9 +366,9 @@ translateDeclaration (path, SFun name params stackSize body)
367366 jsDecl $ jsFun fun
368367
369368 where
370− caseFun :: LVar -> SAlt -> JS
371− caseFun var cse =
372− jsFun (translateCase (Just (translateVariableName var)) cse)
369+ caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
370+ caseFun aux var cse =
371+ jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
373372
374373 getTag :: SAlt -> Maybe String
375374 getTag (SConCase _ tag _ _ _) = Just $ show tag
@@ -378,26 +377,29 @@ translateDeclaration (path, SFun name params stackSize body)
378377 lookupTableName :: String
379378 lookupTableName = idrLTNamespace ++ translateName name
380379
381− lookupTable :: Maybe (String, String) -> LVar -> [SAlt] -> JS
382− lookupTable m var cases =
380+ lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
381+ lookupTable aux var cases =
383382 JSAlloc lookupTableName $ Just (
384− JSObject $ catMaybes $ map (lookupEntry var) cases
383+ JSObject $ catMaybes $ map (lookupEntry aux var) cases
385384 )
386385 where
387− lookupEntry :: LVar -> SAlt -> Maybe (String, JS)
388− lookupEntry var alt = do
386+ lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
387+ lookupEntry aux var alt = do
389388 tag <- getTag alt
390− return (tag, caseFun var alt)
389+ return (tag, caseFun aux var alt)
391390
392391 jsDecl :: JS -> JS
393392 jsDecl = JSAlloc (path ++ translateName name) . Just
394393
395− jsFun :: JS -> JS
396− jsFun body =
397− JSFunction p (
394+ jsFun body = jsFunAux [] body
395+
396+ jsFunAux :: [(LVar, String)] -> JS -> JS
397+ jsFunAux aux body =
398+ JSFunction (p ++ map snd aux) (
398399 JSSeq $
399400 zipWith assignVar [0..] p ++
400401 map allocVar [numP .. (numP + stackSize - 1)] ++
402+ map assignAux aux ++
401403 [JSReturn body]
402404 )
403405 where
@@ -410,6 +412,9 @@ translateDeclaration (path, SFun name params stackSize body)
410412 assignVar :: Int -> String -> JS
411413 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
412414
415+ assignAux :: (LVar, String) -> JS
416+ assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
417+
413418 p :: [String]
414419 p = map translateName params
415420