@@ -12,6 +12,7 @@ import Util.System
1212
1313import Control.Arrow
1414import Control.Applicative ((<$>), (<*>), pure)
15+import Control.Monad.RWS
1516import Data.Char
1617import Numeric
1718import Data.List
@@ -303,7 +304,8 @@ codegenJS_all
303304codegenJS_all target definitions includes filename outputType = do
304305 let bytecode = map toBC definitions
305306 let info = initCompileInfo bytecode
306− let code = concat $ map ((concatMap compileJS) . (translateDecl info)) bytecode
307+ let js = concatMap (translateDecl info) bytecode
308+ let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
307309 let (header, rt) = case target of
308310 Node ->
309311 ("#!/usr/bin/env node\n", "-node")
@@ -314,7 +316,7 @@ codegenJS_all target definitions includes filename outputType = do
314316 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
315317 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
316318 let runtime = header ++ jsbn ++ idrRuntime ++ tgtRuntime
317− writeFile filename $ runtime ++ code ++ main ++ invokeMain
319+ writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
318320 setPermissions filename (emptyPermissions { readable = True
319321 , executable = target == Node
320322 , writable = True
@@ -326,15 +328,59 @@ codegenJS_all target definitions includes filename outputType = do
326328 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
327329 , JSApp (
328330 JSIdent (translateName (sMN 0 "runMain"))
329− ) [ JSIdent "vm"
330− , JSNum (JSInt 0)
331− ]
331+ ) [ JSIdent "vm"
332+ , JSNum (JSInt 0)
333+ ]
332334 ]
333335 )
334336
335337 invokeMain :: String
336338 invokeMain = compileJS $ JSApp (JSIdent "main") []
337339
340+collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
341+collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
342+ where
343+ generateSplitFunction :: (Int,JS) -> JS
344+ generateSplitFunction (depth, JSAlloc name fun) =
345+ JSAlloc (name ++ "$" ++ show depth) fun
346+
347+splitFunction :: JS -> RWS () [(Int,JS)] Int JS
348+splitFunction (JSAlloc name (Just (JSFunction args body))) = do
349+ b <- splitSequence body
350+ return $ JSAlloc name (Just (JSFunction args b))
351+ where
352+ splitSequence :: JS -> RWS () [(Int, JS)] Int JS
353+ splitSequence js@(JSSeq seq) = do
354+ let (pre,post) = break isCall seq in
355+ case post of
356+ [] -> return js
357+ [_] -> return js
358+ (call:rest) -> do
359+ depth <- get
360+ put (depth + 1)
361+ new <- splitFunction (newFun rest)
362+ tell [(depth, new)]
363+ {-return $ JSSeq (pre ++ [newCall depth, call])-}
364+ return $ JSSeq (pre ++ [call, newCall depth])
365+
366+ isCall :: JS -> Bool
367+ isCall (JSApp (JSIdent "i$CALL") _) = True
368+ isCall _ = False
369+
370+ newCall :: Int -> JS
371+ newCall depth =
372+ JSApp (JSIdent "i$CALL") [ JSIdent "vm"
373+ , JSIdent $ name ++ "$" ++ show depth
374+ , JSArray [JSIdent "vm"
375+ , JSIdent "oldbase"
376+ , JSIdent "myoldbase"
377+ ]
378+ ]
379+
380+ newFun :: [JS] -> JS
381+ newFun seq =
382+ JSAlloc name (Just $ JSFunction ["vm", "oldbase", "myoldbase"] (JSSeq seq))
383+
338384
339385translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
340386translateDecl info (name@(MN 0 fun), bc)
@@ -457,9 +503,9 @@ translateConstant (AType ATFloat) = JSType JSFloatTy
457503translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
458504translateConstant PtrType = JSType JSPtrTy
459505translateConstant Forgot = JSType JSForgotTy
460−translateConstant (BI i) = jsBigInt (JSString $ show i)
461506translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
462507translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
508+translateConstant (BI i) = jsBigInt (JSString $ show i)
463509translateConstant (B8 b) = JSWord (JSWord8 b)
464510translateConstant (B16 b) = JSWord (JSWord16 b)
465511translateConstant (B32 b) = JSWord (JSWord32 b)
@@ -508,10 +554,22 @@ jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
508554jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
509555
510556jsCALL :: CompileInfo -> Name -> JS
511−jsCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "myoldbase"]
557+jsCALL _ n =
558+ JSApp (
559+ JSIdent "i$CALL"
560+ ) [ JSIdent "vm", JSIdent (translateName n), JSArray [ JSIdent "vm"
561+ , JSIdent "myoldbase"
562+ ]
563+ ]
512564
513565jsTAILCALL :: CompileInfo -> Name -> JS
514−jsTAILCALL _ n = JSApp (JSIdent (translateName n)) [JSIdent "vm", JSIdent "oldbase"]
566+jsTAILCALL _ n =
567+ JSApp (
568+ JSIdent "i$CALL"
569+ ) [ JSIdent "vm", JSIdent (translateName n), JSArray [ JSIdent "vm"
570+ , JSIdent "oldbase"
571+ ]
572+ ]
515573
516574jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
517575jsFOREIGN _ reg n args =