@@ -325,6 +325,70 @@ inlineJS (JSObject fields) =
325325
326326inlineJS js = js
327327
328+reduceJS :: [JS] -> [JS]
329+reduceJS program =
330+ case partition findConstructors program of
331+ (candidates, rest) ->
332+ map reduce candidates ++ map (reduceCall (map funNames candidates)) rest
333+ where findConstructors :: JS -> Bool
334+ findConstructors js
335+ | (JSAlloc fun (Just (JSFunction [] (JSSeq body)))) <- js =
336+ reducable $ last body
337+ | otherwise = False
338+ where reducable :: JS -> Bool
339+ reducable (JSReturn js) = reducable js
340+ reducable (JSNew _ args) = and $ map reducable args
341+ reducable (JSArray fields) = and $ map reducable fields
342+ reducable (JSNum _) = True
343+ reducable JSNull = True
344+ reducable _ = False
345+
346+ reduce :: JS -> JS
347+ reduce (JSAlloc fun (Just (JSFunction [] (JSSeq body))))
348+ | JSReturn js <- last body = (JSAlloc fun (Just js))
349+ | otherwise = error "this should not happen"
350+
351+ funNames :: JS -> String
352+ funNames (JSAlloc fun _) = fun
353+ funNames _ = error "WTF?"
354+
355+ reduceCall :: [String] -> JS -> JS
356+ reduceCall funs js@(JSApp (JSRaw fun) [])
357+ | fun `elem` funs = JSRaw fun
358+ | otherwise = js
359+
360+ reduceCall funs (JSAlloc fun (Just body)) =
361+ JSAlloc fun (Just $ reduceCall funs body)
362+
363+ reduceCall funs (JSReturn js) =
364+ JSReturn $ reduceCall funs js
365+
366+ reduceCall funs (JSSeq js) =
367+ JSSeq $ map (reduceCall funs) js
368+
369+ reduceCall funs (JSNew con args) =
370+ JSNew con $ map (reduceCall funs) args
371+
372+ reduceCall funs (JSFunction args body) =
373+ JSFunction args $ reduceCall funs body
374+
375+ reduceCall funs (JSApp fun args) =
376+ JSApp (reduceCall funs fun) $ map (reduceCall funs) args
377+
378+ reduceCall funs (JSProj obj field) =
379+ JSProj (reduceCall funs obj) field
380+
381+ reduceCall funs (JSCond conds) =
382+ JSCond $ map (reduceCall funs *** reduceCall funs) conds
383+
384+ reduceCall funs (JSAssign lhs rhs) =
385+ JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
386+
387+ reduceCall funs (JSArray fields) =
388+ JSArray $ map (reduceCall funs) fields
389+
390+ reduceCall _ js = js
391+
328392optimizeJS :: JS -> JS
329393optimizeJS = inlineLoop
330394 where inlineLoop :: JS -> JS
@@ -363,7 +427,8 @@ codegenJavaScript target definitions filename outputType = do
363427 def = map (first translateNamespace) definitions
364428
365429 functions :: [String]
366− functions = map (compileJS . optimizeJS . translateDeclaration) def
430+ functions =
431+ map compileJS (reduceJS $ map (optimizeJS . translateDeclaration) def)
367432
368433 mainLoop :: String
369434 mainLoop = compileJS $
@@ -815,7 +880,7 @@ translateExpression patterncase
815880 (checkTy `jsAnd` checkTag, branch)
816881
817882translateExpression (SCon i name vars) =
818− JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
883+ JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
819884 , JSArray $ map JSVar vars
820885 ]
821886