@@ -14,6 +14,7 @@ import Control.Arrow
1414import Control.Monad (mapM)
1515import Control.Applicative ((<$>), (<*>), pure)
1616import Control.Monad.RWS hiding (mapM)
17+import Control.Monad.State
1718import Data.Char
1819import Numeric
1920import Data.List
@@ -23,6 +24,8 @@ import Data.Traversable hiding (mapM)
2324import System.IO
2425import System.Directory
2526
27+import qualified Data.Map.Strict as M
28+
2629
2730data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
2831 , compileInfoEvalCases :: [Int]
@@ -286,6 +289,9 @@ compileJS' indent (JSNum num)
286289compileJS' indent (JSAssign lhs rhs) =
287290 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
288291
292+compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
293+ "var " ++ name ++ " = " ++ compileJS' 0 val ++ ";\n"
294+
289295compileJS' indent (JSAlloc name val) =
290296 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
291297
@@ -379,7 +385,8 @@ codegenJS_all target definitions includes libs filename outputType = do
379385 let bytecode = map toBC definitions
380386 let info = initCompileInfo bytecode
381387 let js = concatMap (translateDecl info) bytecode
382− let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
388+ let code = concatMap processFunction js
389+ let (cons, opt) = optimizeConstructors code
383390 let (header, rt) = case target of
384391 Node -> ("#!/usr/bin/env node\n", "-node")
385392 JavaScript -> ("", "-browser")
@@ -398,12 +405,23 @@ codegenJS_all target definitions includes libs filename outputType = do
398405 ++ idrRuntime
399406 ++ tgtRuntime
400407 )
401− writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
408+ writeFile filename ( runtime
409+ ++ concatMap compileJS opt
410+ ++ concatMap compileJS cons
411+ ++ main
412+ ++ invokeMain
413+ )
402414 setPermissions filename (emptyPermissions { readable = True
403415 , executable = target == Node
404416 , writable = True
405417 })
406418 where
419+ processFunction :: JS -> [JS]
420+ processFunction js =
421+ (
422+ collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
423+ ) js
424+
407425 includeLibs :: [String] -> String
408426 includeLibs =
409427 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
@@ -468,6 +486,52 @@ codegenJS_all target definitions includes libs filename outputType = do
468486 invokeMain :: String
469487 invokeMain = compileJS $ JSApp (JSIdent "main") []
470488
489+optimizeConstructors :: [JS] -> ([JS], [JS])
490+optimizeConstructors js =
491+ let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
492+ (map (allocCon . snd) (M.toList cons), js')
493+ where
494+ allocCon :: (String, JS) -> JS
495+ allocCon (name, con) = JSAlloc name (Just con)
496+
497+ newConstructor :: Int -> String
498+ newConstructor n = "i$CON$" ++ show n
499+
500+ optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
501+ optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
502+ , JSArray []
503+ , a
504+ , e
505+ ]) = do
506+ s <- get
507+ case M.lookup tag s of
508+ Just (i, c) -> return $ JSIdent i
509+ Nothing -> do let n = newConstructor tag
510+ put $ M.insert tag (n, js) s
511+ return $ JSIdent n
512+
513+ optimizeConstructor' (JSSeq seq) =
514+ JSSeq <$> traverse optimizeConstructor' seq
515+
516+ optimizeConstructor' (JSSwitch reg cond def) = do
517+ cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
518+ def' <- traverse optimizeConstructor' def
519+ return $ JSSwitch reg cond' def'
520+
521+ optimizeConstructor' (JSCond cond) =
522+ JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
523+
524+ optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
525+ body' <- optimizeConstructor' body
526+ return $ JSAlloc fun (Just (JSFunction args body'))
527+
528+ optimizeConstructor' (JSAssign lhs rhs) = do
529+ lhs' <- optimizeConstructor' lhs
530+ rhs' <- optimizeConstructor' rhs
531+ return $ JSAssign lhs' rhs'
532+
533+ optimizeConstructor' js = return js
534+
471535collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
472536collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
473537 where
@@ -760,6 +824,7 @@ jsERROR :: CompileInfo -> String -> JS
760824jsERROR _ = JSError
761825
762826jsSLIDE :: CompileInfo -> Int -> JS
827+jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
763828jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
764829
765830jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
@@ -867,6 +932,15 @@ jsCONSTCASE info reg cases def =
867932 prepBranch bc = JSSeq $ map (translateBC info) bc
868933
869934jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
935+jsPROJECT _ reg loc 0 = JSNoop
936+jsPROJECT _ reg loc 1 =
937+ JSAssign (jsLOC loc) (
938+ JSIndex (
939+ JSProj (translateReg reg) "args"
940+ ) (
941+ JSNum (JSInt 0)
942+ )
943+ )
870944jsPROJECT _ reg loc ar =
871945 JSApp (JSIdent "i$PROJECT") [ translateReg reg
872946 , JSNum (JSInt loc)