git.iko.soy/Idris-dev
on master help sign in
Merge pull request #791 from raichoo/javascript
b9bac0eEdwin Brady
src/IRTS/CodegenJavaScript.hs+119−20
compare with master
unifiedsplit
@@ -314,6 +314,9 @@ jsSubst var new (JSIndex obj field) =
314jsSubst var new (JSCond conds) =
314jsSubst var new (JSCond conds) =
315 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
315 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
316
316
317+jsSubst var new (JSAssign lhs rhs) =
318+ JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
319+
317jsSubst _ _ js = js
320jsSubst _ _ js = js
318
321
319
322
@@ -328,16 +331,24 @@ isJSConstant js
328 | otherwise = False
331 | otherwise = False
329
332
330inlineJS :: JS -> JS
333inlineJS :: JS -> JS
334+inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
335+ inlineJS $ jsSubst "cse" val body
336+
337+inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
338+ JSSeq [ JSAlloc arg (Just (inlineJS val))
339+ , inlineJS cond
340+ ]
341+
331inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
342inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
332− JSThis,JSProj (JSIdent var) "vars"
343+ JSThis,JSProj var "vars"
333 ])
344 ])
334− | var /= "cse" =
345+ | var /= JSIdent "cse" =
335− inlineApply args body 0
346+ inlineApply args body 0
336 where
347 where
337− inlineApply [] body _ = body
348+ inlineApply [] body _ = inlineJS body
338 inlineApply (a:as) body n =
349 inlineApply (a:as) body n =
339 inlineApply as (
350 inlineApply as (
340− jsSubst a (JSIndex (JSProj (JSIdent var) "vars") (JSNum (JSInt n))) body
351+ jsSubst a (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
341 ) (n + 1)
352 ) (n + 1)
342
353
343inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
354inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
@@ -348,9 +359,6 @@ inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
348 ])
359 ])
349 | isJSConstant val = val
360 | isJSConstant val = val
350
361
351−inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
352− JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
353−
354inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
362inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
355 | JSNew con [tag, vals] <- ret
363 | JSNew con [tag, vals] <- ret
356 , opt <- inlineJS val =
364 , opt <- inlineJS val =
@@ -430,6 +438,96 @@ reduceJS js = reduceLoop [] ([], js)
430funName :: JS -> String
438funName :: JS -> String
431funName (JSAlloc fun _) = fun
439funName (JSAlloc fun _) = fun
432
440
441+initConstructors :: [JS] -> [JS]
442+initConstructors js =
443+ let tags = nub $ sort $ concat (map getTags js) in
444+ map createConstant tags ++ replaceConstructors tags js
445+ where
446+ getTags :: JS -> [Int]
447+ getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
448+
449+ getTags (JSNew _ args) = concatMap getTags args
450+
451+ getTags (JSFunction _ body) = getTags body
452+
453+ getTags (JSReturn ret) = getTags ret
454+
455+ getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
456+
457+ getTags (JSSeq seq) = concatMap getTags seq
458+
459+ getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
460+
461+ getTags (JSProj obj _) = getTags obj
462+
463+ getTags (JSArray vals) = concatMap getTags vals
464+
465+ getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
466+
467+ getTags (JSAlloc _ (Just val)) = getTags val
468+
469+ getTags (JSCond conds) =
470+ concatMap (uncurry (++)) $ map (getTags *** getTags) conds
471+
472+ getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
473+
474+ getTags js = []
475+
476+ replaceConstructors :: [Int] -> [JS] -> [JS]
477+ replaceConstructors tags js = map (replaceHelper tags) js
478+ where
479+ replaceHelper :: [Int] -> JS -> JS
480+ replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
481+ | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
482+
483+ replaceHelper tags (JSNew con args) =
484+ JSNew con $ map (replaceHelper tags) args
485+
486+ replaceHelper tags (JSFunction fun body) =
487+ JSFunction fun (replaceHelper tags body)
488+
489+ replaceHelper tags (JSReturn ret) =
490+ JSReturn (replaceHelper tags ret)
491+
492+ replaceHelper tags (JSApp lhs rhs) =
493+ JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)
494+
495+ replaceHelper tags (JSSeq seq) =
496+ JSSeq $ map (replaceHelper tags) seq
497+
498+ replaceHelper tags (JSOp op lhs rhs) =
499+ JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)
500+
501+ replaceHelper tags (JSProj obj field) =
502+ JSProj (replaceHelper tags obj) field
503+
504+ replaceHelper tags (JSArray vals) =
505+ JSArray $ map (replaceHelper tags) vals
506+
507+ replaceHelper tags (JSAssign lhs rhs) =
508+ JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)
509+
510+ replaceHelper tags (JSAlloc var (Just val)) =
511+ JSAlloc var $ Just (replaceHelper tags val)
512+
513+ replaceHelper tags (JSCond conds) =
514+ JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)
515+
516+ replaceHelper tags (JSTernary c t f) =
517+ JSTernary (replaceHelper tags c) (
518+ replaceHelper tags t
519+ ) (
520+ replaceHelper tags f
521+ )
522+
523+ replaceHelper tags js = js
524+
525+ createConstant :: Int -> JS
526+ createConstant tag =
527+ JSAlloc ("__IDRCTR__" ++ show tag) (Just (
528+ JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
529+ ))
530+
433removeIDs :: [JS] -> [JS]
531removeIDs :: [JS] -> [JS]
434removeIDs js =
532removeIDs js =
435 case partition isID js of
533 case partition isID js of
@@ -651,7 +749,7 @@ codegenJavaScript target definitions filename outputType = do
651
749
652 functions :: [String]
750 functions :: [String]
653 functions =
751 functions =
654− map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
752+ map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))
655
753
656 mainLoop :: String
754 mainLoop :: String
657 mainLoop = compileJS $
755 mainLoop = compileJS $
@@ -780,7 +878,7 @@ translateConstant c =
780
878
781translateDeclaration :: (String, SDecl) -> JS
879translateDeclaration :: (String, SDecl) -> JS
782translateDeclaration (path, SFun name params stackSize body)
880translateDeclaration (path, SFun name params stackSize body)
783− | (MN _ ap) <- name
881+ | (MN _ ap) <- name
784 , (SLet var val next) <- body
882 , (SLet var val next) <- body
785 , (SChkCase cvar cases) <- next
883 , (SChkCase cvar cases) <- next
786 , ap == txt "APPLY" =
884 , ap == txt "APPLY" =
@@ -789,20 +887,21 @@ translateDeclaration (path, SFun name params stackSize body)
789 JSSeq [ lookupTable [(var, "chk")] var cases
887 JSSeq [ lookupTable [(var, "chk")] var cases
790 , jsDecl $ JSFunction ["fn0", "arg0"] (
888 , jsDecl $ JSFunction ["fn0", "arg0"] (
791 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
889 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
792− , JSReturn $ jsLet (translateVariableName var) (
890+ , JSAlloc (translateVariableName var) (
793− translateExpression val
891+ Just $ translateExpression val
892+ )
794− ) (JSTernary (
893+ , JSReturn $ (JSTernary (
795− (JSVar var `jsInstanceOf` jsCon) `jsAnd`
894+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`
796− (hasProp lookupTableName (translateVariableName var))
895+ (hasProp lookupTableName (translateVariableName var))
797− ) (JSIdent $
896+ ) (JSIdent $
798− lookupTableName ++ lookup
897+ lookupTableName ++ lookup
799− ) JSNull
898+ ) JSNull
800− )
899+ )
801 ]
900 ]
802 )
901 )
803 ]
902 ]
804
903
805− | (MN _ ev) <- name
904+ | (MN _ ev) <- name
806 , (SChkCase var cases) <- body
905 , (SChkCase var cases) <- body
807 , ev == txt "EVAL" =
906 , ev == txt "EVAL" =
808 JSSeq [ lookupTable [] var cases
907 JSSeq [ lookupTable [] var cases