@@ -314,6 +314,9 @@ jsSubst var new (JSIndex obj field) =
314314jsSubst var new (JSCond conds) =
315315 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
316316
317+jsSubst var new (JSAssign lhs rhs) =
318+ JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
319+
317320jsSubst _ _ js = js
318321
319322
@@ -328,16 +331,24 @@ isJSConstant js
328331 | otherwise = False
329332
330333inlineJS :: 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+
331342inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
332− JSThis,JSProj (JSIdent var) "vars"
343+ JSThis,JSProj var "vars"
333344 ])
334− | var /= "cse" =
335− inlineApply args body 0
345+ | var /= JSIdent "cse" =
346+ inlineApply args body 0
336347 where
337− inlineApply [] body _ = body
348+ inlineApply [] body _ = inlineJS body
338349 inlineApply (a:as) body n =
339350 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
341352 ) (n + 1)
342353
343354inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
@@ -348,9 +359,6 @@ inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
348359 ])
349360 | isJSConstant val = val
350361
351−inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
352− JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
353−
354362inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
355363 | JSNew con [tag, vals] <- ret
356364 , opt <- inlineJS val =
@@ -430,6 +438,96 @@ reduceJS js = reduceLoop [] ([], js)
430438funName :: JS -> String
431439funName (JSAlloc fun _) = fun
432440
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+
433531removeIDs :: [JS] -> [JS]
434532removeIDs js =
435533 case partition isID js of
@@ -651,7 +749,7 @@ codegenJavaScript target definitions filename outputType = do
651749
652750 functions :: [String]
653751 functions =
654− map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
752+ map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))
655753
656754 mainLoop :: String
657755 mainLoop = compileJS $
@@ -780,7 +878,7 @@ translateConstant c =
780878
781879translateDeclaration :: (String, SDecl) -> JS
782880translateDeclaration (path, SFun name params stackSize body)
783− | (MN _ ap) <- name
881+ | (MN _ ap) <- name
784882 , (SLet var val next) <- body
785883 , (SChkCase cvar cases) <- next
786884 , ap == txt "APPLY" =
@@ -789,20 +887,21 @@ translateDeclaration (path, SFun name params stackSize body)
789887 JSSeq [ lookupTable [(var, "chk")] var cases
790888 , jsDecl $ JSFunction ["fn0", "arg0"] (
791889 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
792− , JSReturn $ jsLet (translateVariableName var) (
793− translateExpression val
794− ) (JSTernary (
795− (JSVar var `jsInstanceOf` jsCon) `jsAnd`
796− (hasProp lookupTableName (translateVariableName var))
797− ) (JSIdent $
798− lookupTableName ++ lookup
799− ) JSNull
800− )
890+ , JSAlloc (translateVariableName var) (
891+ Just $ translateExpression val
892+ )
893+ , JSReturn $ (JSTernary (
894+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`
895+ (hasProp lookupTableName (translateVariableName var))
896+ ) (JSIdent $
897+ lookupTableName ++ lookup
898+ ) JSNull
899+ )
801900 ]
802901 )
803902 ]
804903
805− | (MN _ ev) <- name
904+ | (MN _ ev) <- name
806905 , (SChkCase var cases) <- body
807906 , ev == txt "EVAL" =
808907 JSSeq [ lookupTable [] var cases