a3ccdef · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #1347 from raichoo/javascript

a3ccdefraichoo12 years ago

src/IRTS/CodegenJavaScript.hs+76−2

compare with master

unifiedsplit

@@ -14,6 +14,7 @@ import Control.Arrow

14import Control.Monad (mapM)

15import Control.Applicative ((<$>), (<*>), pure)

16import Control.Monad.RWS hiding (mapM)

17+import Control.Monad.State

17import Data.Char

18import Data.Char

18import Numeric

19import Numeric

19import Data.List

20import Data.List

@@ -23,6 +24,8 @@ import Data.Traversable hiding (mapM)

23import System.IO

24import System.IO

24import System.Directory

25import System.Directory

27+import qualified Data.Map.Strict as M

28+

27data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]

30data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]

28 , compileInfoEvalCases :: [Int]

31 , compileInfoEvalCases :: [Int]

@@ -286,6 +289,9 @@ compileJS' indent (JSNum num)

286compileJS' indent (JSAssign lhs rhs) =

289compileJS' indent (JSAssign lhs rhs) =

287 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs

290 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs

288

291

292+compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =

293+ "var " ++ name ++ " = " ++ compileJS' 0 val ++ ";\n"

294+

289compileJS' indent (JSAlloc name val) =

295compileJS' indent (JSAlloc name val) =

290 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val

296 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val

291

297

@@ -379,7 +385,8 @@ codegenJS_all target definitions includes libs filename outputType = do

379 let bytecode = map toBC definitions

385 let bytecode = map toBC definitions

380 let info = initCompileInfo bytecode

386 let info = initCompileInfo bytecode

381 let js = concatMap (translateDecl info) bytecode

387 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

383 let (header, rt) = case target of

390 let (header, rt) = case target of

384 Node -> ("#!/usr/bin/env node\n", "-node")

391 Node -> ("#!/usr/bin/env node\n", "-node")

385 JavaScript -> ("", "-browser")

392 JavaScript -> ("", "-browser")

@@ -398,12 +405,23 @@ codegenJS_all target definitions includes libs filename outputType = do

398 ++ idrRuntime

405 ++ idrRuntime

399 ++ tgtRuntime

406 ++ tgtRuntime

400 )

407 )

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+ )

402 setPermissions filename (emptyPermissions { readable = True

414 setPermissions filename (emptyPermissions { readable = True

403 , executable = target == Node

415 , executable = target == Node

404 , writable = True

416 , writable = True

405 })

417 })

406 where

418 where

419+ processFunction :: JS -> [JS]

420+ processFunction js =

421+ (

422+ collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)

423+ ) js

424+

407 includeLibs :: [String] -> String

425 includeLibs :: [String] -> String

408 includeLibs =

426 includeLibs =

409 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")

427 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")

@@ -468,6 +486,52 @@ codegenJS_all target definitions includes libs filename outputType = do

468 invokeMain :: String

486 invokeMain :: String

469 invokeMain = compileJS $ JSApp (JSIdent "main") []

487 invokeMain = compileJS $ JSApp (JSIdent "main") []

470

488

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+

471collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]

535collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]

472collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]

536collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]

473 where

537 where

@@ -760,6 +824,7 @@ jsERROR :: CompileInfo -> String -> JS

760jsERROR _ = JSError

824jsERROR _ = JSError

761

825

762jsSLIDE :: CompileInfo -> Int -> JS

826jsSLIDE :: CompileInfo -> Int -> JS

827+jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)

763jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]

828jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]

764

829

765jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS

830jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS

@@ -867,6 +932,15 @@ jsCONSTCASE info reg cases def =

867 prepBranch bc = JSSeq $ map (translateBC info) bc

932 prepBranch bc = JSSeq $ map (translateBC info) bc

868

933

869jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS

934jsPROJECT :: 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+ )

870jsPROJECT _ reg loc ar =

944jsPROJECT _ reg loc ar =

871 JSApp (JSIdent "i$PROJECT") [ translateReg reg

945 JSApp (JSIdent "i$PROJECT") [ translateReg reg

872 , JSNum (JSInt loc)

946 , JSNum (JSInt loc)