git.iko.soy/Idris-dev
on master help sign in
javascript: reduce functions
8947a2eraichoo
src/IRTS/CodegenJavaScript.hs+67−2
compare with master
unifiedsplit
@@ -325,6 +325,70 @@ inlineJS (JSObject fields) =
325
325
326inlineJS js = js
326inlineJS js = js
327
327
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+
328optimizeJS :: JS -> JS
392optimizeJS :: JS -> JS
329optimizeJS = inlineLoop
393optimizeJS = inlineLoop
330 where inlineLoop :: JS -> JS
394 where inlineLoop :: JS -> JS
@@ -363,7 +427,8 @@ codegenJavaScript target definitions filename outputType = do
363 def = map (first translateNamespace) definitions
427 def = map (first translateNamespace) definitions
364
428
365 functions :: [String]
429 functions :: [String]
430+ functions =
366− functions = map (compileJS . optimizeJS . translateDeclaration) def
431+ map compileJS (reduceJS $ map (optimizeJS . translateDeclaration) def)
367
432
368 mainLoop :: String
433 mainLoop :: String
369 mainLoop = compileJS $
434 mainLoop = compileJS $
@@ -815,7 +880,7 @@ translateExpression patterncase
815 (checkTy `jsAnd` checkTag, branch)
880 (checkTy `jsAnd` checkTag, branch)
816
881
817translateExpression (SCon i name vars) =
882translateExpression (SCon i name vars) =
818− JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
883+ JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
819 , JSArray $ map JSVar vars
884 , JSArray $ map JSVar vars
820 ]
885 ]
821
886