git.iko.soy/Idris-dev
on master help sign in
javascript: hardwired apply lookuptable
10d4cd6raichoo
src/IRTS/CodegenJavaScript.hs+21−16
compare with master
unifiedsplit
@@ -334,11 +334,10 @@ translateDeclaration (path, SFun name params stackSize body)
334 , (SLet var val next) <- body
334 , (SLet var val next) <- body
335 , (SChkCase cvar cases) <- next =
335 , (SChkCase cvar cases) <- next =
336 let fun = translateExpression body in
336 let fun = translateExpression body in
337− {-jsDecl $ jsFun fun-}
338− JSSeq [ lookupTable Nothing var cases
337+ JSSeq [ lookupTable [(var, "chk")] var cases
339 , jsDecl $ JSFunction ["fn0", "arg0"] (
338 , jsDecl $ JSFunction ["fn0", "arg0"] (
340 JSSeq [ JSRaw "var __var_0 = fn0"
339 JSSeq [ JSRaw "var __var_0 = fn0"
341− , jsLet (translateVariableName var) (
340+ , JSReturn $ jsLet (translateVariableName var) (
342 translateExpression val
341 translateExpression val
343 ) (JSRaw $
342 ) (JSRaw $
344 concat [ "(" ++ translateVariableName var ++ " instanceof __IDRRT__Con "
343 concat [ "(" ++ translateVariableName var ++ " instanceof __IDRRT__Con "
@@ -352,7 +351,7 @@ translateDeclaration (path, SFun name params stackSize body)
352
351
353 | (MN _ "EVAL") <- name
352 | (MN _ "EVAL") <- name
354 , (SChkCase var cases) <- body =
353 , (SChkCase var cases) <- body =
355− JSSeq [ lookupTable Nothing var cases
354+ JSSeq [ lookupTable [] var cases
356 , jsDecl $ JSFunction ["arg0"] (JSRaw $
355 , jsDecl $ JSFunction ["arg0"] (JSRaw $
357 concat [ "if (arg0 instanceof __IDRRT__Con "
356 concat [ "if (arg0 instanceof __IDRRT__Con "
358 , " && " ++ lookupTableName ++ ".hasOwnProperty(arg0.tag))"
357 , " && " ++ lookupTableName ++ ".hasOwnProperty(arg0.tag))"
@@ -367,9 +366,9 @@ translateDeclaration (path, SFun name params stackSize body)
367 jsDecl $ jsFun fun
366 jsDecl $ jsFun fun
368
367
369 where
368 where
370− caseFun :: LVar -> SAlt -> JS
369+ caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
371− caseFun var cse =
370+ caseFun aux var cse =
372− jsFun (translateCase (Just (translateVariableName var)) cse)
371+ jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
373
372
374 getTag :: SAlt -> Maybe String
373 getTag :: SAlt -> Maybe String
375 getTag (SConCase _ tag _ _ _) = Just $ show tag
374 getTag (SConCase _ tag _ _ _) = Just $ show tag
@@ -378,26 +377,29 @@ translateDeclaration (path, SFun name params stackSize body)
378 lookupTableName :: String
377 lookupTableName :: String
379 lookupTableName = idrLTNamespace ++ translateName name
378 lookupTableName = idrLTNamespace ++ translateName name
380
379
381− lookupTable :: Maybe (String, String) -> LVar -> [SAlt] -> JS
380+ lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
382− lookupTable m var cases =
381+ lookupTable aux var cases =
383 JSAlloc lookupTableName $ Just (
382 JSAlloc lookupTableName $ Just (
384− JSObject $ catMaybes $ map (lookupEntry var) cases
383+ JSObject $ catMaybes $ map (lookupEntry aux var) cases
385 )
384 )
386 where
385 where
387− lookupEntry :: LVar -> SAlt -> Maybe (String, JS)
386+ lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
388− lookupEntry var alt = do
387+ lookupEntry aux var alt = do
389 tag <- getTag alt
388 tag <- getTag alt
390− return (tag, caseFun var alt)
389+ return (tag, caseFun aux var alt)
391
390
392 jsDecl :: JS -> JS
391 jsDecl :: JS -> JS
393 jsDecl = JSAlloc (path ++ translateName name) . Just
392 jsDecl = JSAlloc (path ++ translateName name) . Just
394
393
395− jsFun :: JS -> JS
394+ jsFun body = jsFunAux [] body
396− jsFun body =
395+
396+ jsFunAux :: [(LVar, String)] -> JS -> JS
397+ jsFunAux aux body =
397− JSFunction p (
398+ JSFunction (p ++ map snd aux) (
398 JSSeq $
399 JSSeq $
399 zipWith assignVar [0..] p ++
400 zipWith assignVar [0..] p ++
400 map allocVar [numP .. (numP + stackSize - 1)] ++
401 map allocVar [numP .. (numP + stackSize - 1)] ++
402+ map assignAux aux ++
401 [JSReturn body]
403 [JSReturn body]
402 )
404 )
403 where
405 where
@@ -410,6 +412,9 @@ translateDeclaration (path, SFun name params stackSize body)
410 assignVar :: Int -> String -> JS
412 assignVar :: Int -> String -> JS
411 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
413 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
412
414
415+ assignAux :: (LVar, String) -> JS
416+ assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
417+
413 p :: [String]
418 p :: [String]
414 p = map translateName params
419 p = map translateName params
415
420